diff --git a/common_reference.h b/common_reference.h deleted file mode 100644 index 93a511bbf..000000000 --- a/common_reference.h +++ /dev/null @@ -1,70 +0,0 @@ -/***************************************************************************** -Copyright (c) 2011-2014, The OpenBLAS Project -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - 3. Neither the name of the OpenBLAS project nor the names of - its contributors may be used to endorse or promote products - derived from this software without specific prior written - permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE -USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -**********************************************************************************/ -#ifndef ASSEMBLER - -#define REF_BU f -#define BLASFUNC_REF_2(x,y) BLASFUNC(x## y) -#define BLASFUNC_REF_1(x,y) BLASFUNC_REF_2(x,y) -#define BLASFUNC_REF(x) BLASFUNC_REF_1(x,REF_BU) - -void BLASFUNC_REF(srot) (blasint *, float *, blasint *, float *, blasint *, float *, float *); -void BLASFUNC_REF(drot) (blasint *, double *, blasint *, double *, blasint *, double *, double *); -void BLASFUNC_REF(qrot) (blasint *, xdouble *, blasint *, xdouble *, blasint *, xdouble *, xdouble *); -void BLASFUNC_REF(csrot) (blasint *, float *, blasint *, float *, blasint *, float *, float *); -void BLASFUNC_REF(zdrot) (blasint *, double *, blasint *, double *, blasint *, double *, double *); -void BLASFUNC_REF(xqrot) (blasint *, xdouble *, blasint *, xdouble *, blasint *, xdouble *, xdouble *); - -void BLASFUNC_REF(sswap) (blasint *, float *, blasint *, float *, blasint *); -void BLASFUNC_REF(dswap) (blasint *, double *, blasint *, double *, blasint *); -void BLASFUNC_REF(qswap) (blasint *, xdouble *, blasint *, xdouble *, blasint *); -void BLASFUNC_REF(cswap) (blasint *, float *, blasint *, float *, blasint *); -void BLASFUNC_REF(zswap) (blasint *, double *, blasint *, double *, blasint *); -void BLASFUNC_REF(xswap) (blasint *, xdouble *, blasint *, xdouble *, blasint *); - -void BLASFUNC_REF(saxpy) (blasint *, float *, float *, blasint *, float *, blasint *); -void BLASFUNC_REF(daxpy) (blasint *, double *, double *, blasint *, double *, blasint *); -void BLASFUNC_REF(caxpy) (blasint *, float *, float *, blasint *, float *, blasint *); -void BLASFUNC_REF(zaxpy) (blasint *, double *, double *, blasint *, double *, blasint *); - -float _Complex BLASFUNC_REF(cdotu) (blasint *, float *, blasint *, float *, blasint *); -float _Complex BLASFUNC_REF(cdotc) (blasint *, float *, blasint *, float *, blasint *); -double _Complex BLASFUNC_REF(zdotu) (blasint *, double *, blasint *, double *, blasint *); -double _Complex BLASFUNC_REF(zdotc) (blasint *, double *, blasint *, double *, blasint *); - -void BLASFUNC_REF(drotmg)(double *, double *, double *, double *, double *); - -double BLASFUNC_REF(dsdot)(blasint *, float *, blasint *, float *, blasint*); - -FLOATRET BLASFUNC_REF(samax) (blasint *, float *, blasint *); - -#endif diff --git a/reference/LICENSE b/reference/LICENSE deleted file mode 100644 index 85061f29f..000000000 --- a/reference/LICENSE +++ /dev/null @@ -1,23 +0,0 @@ -This directory contains the reference implementation of BLAS -which is obtainable at: http://netlib.org/blas/ - -The license, obtained from http://netlib.org/blas/faq.html#2 on November 3, -2010, is as follows: - -2) Are there legal restrictions on the use of BLAS reference implementation -software? - -The reference BLAS is a freely-available software package. It is available from -netlib via anonymous ftp and the World Wide Web. Thus, it can be included in -commercial software packages (and has been). We only ask that proper credit be -given to the authors. - -Like all software, it is copyrighted. It is not trademarked, but we do ask the -following: - -If you modify the source for these routines we ask that you change the name of -the routine and comment the changes made to the original. - -We will gladly answer any questions regarding the software. If a modification -is done, however, it is the responsibility of the person who modified the -routine to provide support. diff --git a/reference/Makefile b/reference/Makefile deleted file mode 100644 index fb52c860d..000000000 --- a/reference/Makefile +++ /dev/null @@ -1,181 +0,0 @@ -TOPDIR = .. -include $(TOPDIR)/Makefile.system - -ifeq ($(ARCH), x86) -SUPPORT_GEMM3M = 1 -endif - -ifeq ($(ARCH), x86_64) -SUPPORT_GEMM3M = 1 -endif - -ifeq ($(ARCH), ia64) -SUPPORT_GEMM3M = 1 -endif - -ifeq ($(ARCH), MIPS) -SUPPORT_GEMM3M = 1 -endif - -SBLAS1OBJS = \ - saxpyf.$(SUFFIX) sswapf.$(SUFFIX) \ - scopyf.$(SUFFIX) sscalf.$(SUFFIX) \ - sdotf.$(SUFFIX) sdsdotf.$(SUFFIX) dsdotf.$(SUFFIX) \ - sasumf.$(SUFFIX) snrm2f.$(SUFFIX) \ - smaxf.$(SUFFIX) samaxf.$(SUFFIX) ismaxf.$(SUFFIX) isamaxf.$(SUFFIX) \ - sminf.$(SUFFIX) saminf.$(SUFFIX) isminf.$(SUFFIX) isaminf.$(SUFFIX) \ - srotf.$(SUFFIX) srotgf.$(SUFFIX) srotmf.$(SUFFIX) srotmgf.$(SUFFIX) \ - -SBLAS2OBJS = \ - sgemvf.$(SUFFIX) sgerf.$(SUFFIX) \ - strsvf.$(SUFFIX) strmvf.$(SUFFIX) ssymvf.$(SUFFIX) \ - ssyrf.$(SUFFIX) ssyr2f.$(SUFFIX) sgbmvf.$(SUFFIX) \ - ssbmvf.$(SUFFIX) sspmvf.$(SUFFIX) \ - ssprf.$(SUFFIX) sspr2f.$(SUFFIX) \ - stbsvf.$(SUFFIX) stbmvf.$(SUFFIX) \ - stpsvf.$(SUFFIX) stpmvf.$(SUFFIX) - -SBLAS3OBJS = \ - sgemmf.$(SUFFIX) ssymmf.$(SUFFIX) strmmf.$(SUFFIX) \ - strsmf.$(SUFFIX) ssyrkf.$(SUFFIX) ssyr2kf.$(SUFFIX) - -DBLAS1OBJS = \ - daxpyf.$(SUFFIX) dswapf.$(SUFFIX) \ - dcopyf.$(SUFFIX) dscalf.$(SUFFIX) \ - ddotf.$(SUFFIX) \ - dasumf.$(SUFFIX) dnrm2f.$(SUFFIX) \ - dmaxf.$(SUFFIX) damaxf.$(SUFFIX) idmaxf.$(SUFFIX) idamaxf.$(SUFFIX) \ - dminf.$(SUFFIX) daminf.$(SUFFIX) idminf.$(SUFFIX) idaminf.$(SUFFIX) \ - drotf.$(SUFFIX) drotgf.$(SUFFIX) drotmf.$(SUFFIX) drotmgf.$(SUFFIX) \ - -DBLAS2OBJS = \ - dgemvf.$(SUFFIX) dgerf.$(SUFFIX) \ - dtrsvf.$(SUFFIX) dtrmvf.$(SUFFIX) dsymvf.$(SUFFIX) \ - dsyrf.$(SUFFIX) dsyr2f.$(SUFFIX) dgbmvf.$(SUFFIX) \ - dsbmvf.$(SUFFIX) dspmvf.$(SUFFIX) \ - dsprf.$(SUFFIX) dspr2f.$(SUFFIX) \ - dtbsvf.$(SUFFIX) dtbmvf.$(SUFFIX) \ - dtpsvf.$(SUFFIX) dtpmvf.$(SUFFIX) - -DBLAS3OBJS = \ - dgemmf.$(SUFFIX) dsymmf.$(SUFFIX) dtrmmf.$(SUFFIX) \ - dtrsmf.$(SUFFIX) dsyrkf.$(SUFFIX) dsyr2kf.$(SUFFIX) - -CBLAS1OBJS = \ - caxpyf.$(SUFFIX) caxpycf.$(SUFFIX) cswapf.$(SUFFIX) \ - ccopyf.$(SUFFIX) cscalf.$(SUFFIX) csscalf.$(SUFFIX) \ - cdotcf.$(SUFFIX) cdotuf.$(SUFFIX) \ - scasumf.$(SUFFIX) scnrm2f.$(SUFFIX) \ - scamaxf.$(SUFFIX) icamaxf.$(SUFFIX) \ - scaminf.$(SUFFIX) icaminf.$(SUFFIX) \ - csrotf.$(SUFFIX) crotgf.$(SUFFIX) \ - -CBLAS2OBJS = \ - cgemvf.$(SUFFIX) cgeruf.$(SUFFIX) cgercf.$(SUFFIX) \ - ctrsvf.$(SUFFIX) ctrmvf.$(SUFFIX) csymvf.$(SUFFIX) \ - csyrf.$(SUFFIX) csyr2f.$(SUFFIX) cgbmvf.$(SUFFIX) \ - csbmvf.$(SUFFIX) cspmvf.$(SUFFIX) \ - csprf.$(SUFFIX) cspr2f.$(SUFFIX) \ - ctbsvf.$(SUFFIX) ctbmvf.$(SUFFIX) \ - ctpsvf.$(SUFFIX) ctpmvf.$(SUFFIX) \ - chemvf.$(SUFFIX) chbmvf.$(SUFFIX) \ - cherf.$(SUFFIX) cher2f.$(SUFFIX) \ - chpmvf.$(SUFFIX) chprf.$(SUFFIX) chpr2f.$(SUFFIX) - -CBLAS3OBJS = \ - cgemmf.$(SUFFIX) csymmf.$(SUFFIX) ctrmmf.$(SUFFIX) \ - ctrsmf.$(SUFFIX) csyrkf.$(SUFFIX) csyr2kf.$(SUFFIX) \ - chemmf.$(SUFFIX) cherkf.$(SUFFIX) cher2kf.$(SUFFIX) - -ZBLAS1OBJS = \ - zaxpyf.$(SUFFIX) zaxpycf.$(SUFFIX) zswapf.$(SUFFIX) \ - zcopyf.$(SUFFIX) zscalf.$(SUFFIX) zdscalf.$(SUFFIX) \ - zdotcf.$(SUFFIX) zdotuf.$(SUFFIX) \ - dzasumf.$(SUFFIX) dznrm2f.$(SUFFIX) \ - dzamaxf.$(SUFFIX) izamaxf.$(SUFFIX) \ - dzaminf.$(SUFFIX) izaminf.$(SUFFIX) \ - zdrotf.$(SUFFIX) zrotgf.$(SUFFIX) \ - -ZBLAS2OBJS = \ - zgemvf.$(SUFFIX) zgeruf.$(SUFFIX) zgercf.$(SUFFIX) \ - ztrsvf.$(SUFFIX) ztrmvf.$(SUFFIX) zsymvf.$(SUFFIX) \ - zsyrf.$(SUFFIX) zsyr2f.$(SUFFIX) zgbmvf.$(SUFFIX) \ - zsbmvf.$(SUFFIX) zspmvf.$(SUFFIX) \ - zsprf.$(SUFFIX) zspr2f.$(SUFFIX) \ - ztbsvf.$(SUFFIX) ztbmvf.$(SUFFIX) \ - ztpsvf.$(SUFFIX) ztpmvf.$(SUFFIX) \ - zhemvf.$(SUFFIX) zhbmvf.$(SUFFIX) \ - zherf.$(SUFFIX) zher2f.$(SUFFIX) \ - zhpmvf.$(SUFFIX) zhprf.$(SUFFIX) zhpr2f.$(SUFFIX) - -ZBLAS3OBJS = \ - zgemmf.$(SUFFIX) zsymmf.$(SUFFIX) ztrmmf.$(SUFFIX) \ - ztrsmf.$(SUFFIX) zsyrkf.$(SUFFIX) zsyr2kf.$(SUFFIX) \ - zhemmf.$(SUFFIX) zherkf.$(SUFFIX) zher2kf.$(SUFFIX) - -ifdef SUPPORT_GEMM3M - -CBLAS3OBJS += cgemm3mf.$(SUFFIX) csymm3mf.$(SUFFIX) chemm3mf.$(SUFFIX) - -ZBLAS3OBJS += zgemm3mf.$(SUFFIX) zsymm3mf.$(SUFFIX) zhemm3mf.$(SUFFIX) - -endif - -SBLASOBJS = $(SBLAS1OBJS) $(SBLAS2OBJS) $(SBLAS3OBJS) -DBLASOBJS = $(DBLAS1OBJS) $(DBLAS2OBJS) $(DBLAS3OBJS) -QBLASOBJS = $(QBLAS1OBJS) $(QBLAS2OBJS) $(QBLAS3OBJS) -CBLASOBJS = $(CBLAS1OBJS) $(CBLAS2OBJS) $(CBLAS3OBJS) -ZBLASOBJS = $(ZBLAS1OBJS) $(ZBLAS2OBJS) $(ZBLAS3OBJS) -XBLASOBJS = $(XBLAS1OBJS) $(XBLAS2OBJS) $(XBLAS3OBJS) - -ifneq ($(NO_LAPACK), 1) - -SBLASOBJS += \ - sgetf2f.$(SUFFIX) sgetrff.$(SUFFIX) slauu2f.$(SUFFIX) slauumf.$(SUFFIX) \ - spotf2f.$(SUFFIX) spotrff.$(SUFFIX) strti2f.$(SUFFIX) strtrif.$(SUFFIX) \ - slaswpf.$(SUFFIX) sgetrsf.$(SUFFIX) sgesvf.$(SUFFIX) spotrif.$(SUFFIX) \ - -DBLASOBJS += \ - dgetf2f.$(SUFFIX) dgetrff.$(SUFFIX) dlauu2f.$(SUFFIX) dlauumf.$(SUFFIX) \ - dpotf2f.$(SUFFIX) dpotrff.$(SUFFIX) dtrti2f.$(SUFFIX) dtrtrif.$(SUFFIX) \ - dlaswpf.$(SUFFIX) dgetrsf.$(SUFFIX) dgesvf.$(SUFFIX) dpotrif.$(SUFFIX) \ - -QBLASOBJS += -# \ - qgetf2f.$(SUFFIX) qgetrff.$(SUFFIX) qlauu2f.$(SUFFIX) qlauumf.$(SUFFIX) \ - qpotf2f.$(SUFFIX) qpotrff.$(SUFFIX) qtrti2f.$(SUFFIX) qtrtrif.$(SUFFIX) \ - qlaswpf.$(SUFFIX) qgetrsf.$(SUFFIX) qgesvf.$(SUFFIX) qpotrif.$(SUFFIX) \ - -CBLASOBJS += \ - cgetf2f.$(SUFFIX) cgetrff.$(SUFFIX) clauu2f.$(SUFFIX) clauumf.$(SUFFIX) \ - cpotf2f.$(SUFFIX) cpotrff.$(SUFFIX) ctrti2f.$(SUFFIX) ctrtrif.$(SUFFIX) \ - claswpf.$(SUFFIX) cgetrsf.$(SUFFIX) cgesvf.$(SUFFIX) cpotrif.$(SUFFIX) \ - -ZBLASOBJS += \ - zgetf2f.$(SUFFIX) zgetrff.$(SUFFIX) zlauu2f.$(SUFFIX) zlauumf.$(SUFFIX) \ - zpotf2f.$(SUFFIX) zpotrff.$(SUFFIX) ztrti2f.$(SUFFIX) ztrtrif.$(SUFFIX) \ - zlaswpf.$(SUFFIX) zgetrsf.$(SUFFIX) zgesvf.$(SUFFIX) zpotrif.$(SUFFIX) \ - -XBLASOBJS += -# \ - xgetf2f.$(SUFFIX) xgetrff.$(SUFFIX) xlauu2f.$(SUFFIX) xlauumf.$(SUFFIX) \ - xpotf2f.$(SUFFIX) xpotrff.$(SUFFIX) xtrti2f.$(SUFFIX) xtrtrif.$(SUFFIX) \ - xlaswpf.$(SUFFIX) xgetrsf.$(SUFFIX) xgesvf.$(SUFFIX) xpotrif.$(SUFFIX) \ - -endif - -include $(TOPDIR)/Makefile.tail - -all :: libs - -clean :: - -level1 : $(SBLAS1OBJS) $(DBLAS1OBJS) $(QBLAS1OBJS) $(CBLAS1OBJS) $(ZBLAS1OBJS) $(XBLAS1OBJS) - $(AR) $(ARFLAGS) -ru $(TOPDIR)/$(LIBNAME) $^ - -level2 : $(SBLAS2OBJS) $(DBLAS2OBJS) $(QBLAS2OBJS) $(CBLAS2OBJS) $(ZBLAS2OBJS) $(XBLAS2OBJS) - $(AR) $(ARFLAGS) -ru $(TOPDIR)/$(LIBNAME) $^ - -level3 : $(SBLAS3OBJS) $(DBLAS3OBJS) $(QBLAS3OBJS) $(CBLAS3OBJS) $(ZBLAS3OBJS) $(XBLAS3OBJS) - $(AR) $(ARFLAGS) -ru $(TOPDIR)/$(LIBNAME) $^ - diff --git a/reference/caxpycf.f b/reference/caxpycf.f deleted file mode 100644 index 092c8c12e..000000000 --- a/reference/caxpycf.f +++ /dev/null @@ -1,35 +0,0 @@ - subroutine caxpycf(n,ca,cx,incx,cy,incy) -c -c constant times a vector plus a vector. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*),cy(*),ca - integer i,incx,incy,ix,iy,n - INTRINSIC conjg -c - if(n.le.0)return - if (abs(real(ca)) + abs(aimag(ca)) .eq. 0.0 ) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - cy(iy) = cy(iy) + ca*conjg(cx(ix)) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - cy(i) = cy(i) + ca*conjg(cx(i)) - 30 continue - return - end diff --git a/reference/caxpyf.f b/reference/caxpyf.f deleted file mode 100644 index 554f71d1b..000000000 --- a/reference/caxpyf.f +++ /dev/null @@ -1,34 +0,0 @@ - subroutine caxpyf(n,ca,cx,incx,cy,incy) -c -c constant times a vector plus a vector. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*),cy(*),ca - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if (abs(real(ca)) + abs(aimag(ca)) .eq. 0.0 ) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - cy(iy) = cy(iy) + ca*cx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - cy(i) = cy(i) + ca*cx(i) - 30 continue - return - end diff --git a/reference/ccopyf.f b/reference/ccopyf.f deleted file mode 100644 index 2a3325553..000000000 --- a/reference/ccopyf.f +++ /dev/null @@ -1,33 +0,0 @@ - subroutine ccopyf(n,cx,incx,cy,incy) -c -c copies a vector, x, to a vector, y. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*),cy(*) - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - cy(iy) = cx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - cy(i) = cx(i) - 30 continue - return - end diff --git a/reference/cdotcf.f b/reference/cdotcf.f deleted file mode 100644 index 79aa39c8a..000000000 --- a/reference/cdotcf.f +++ /dev/null @@ -1,38 +0,0 @@ - complex function cdotcf(n,cx,incx,cy,incy) -c -c forms the dot product of two vectors, conjugating the first -c vector. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*),cy(*),ctemp - integer i,incx,incy,ix,iy,n -c - ctemp = (0.0,0.0) - cdotcf = (0.0,0.0) - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ctemp = ctemp + conjg(cx(ix))*cy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - cdotcf = ctemp - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ctemp = ctemp + conjg(cx(i))*cy(i) - 30 continue - cdotcf = ctemp - return - end diff --git a/reference/cdotuf.f b/reference/cdotuf.f deleted file mode 100644 index bf93390a3..000000000 --- a/reference/cdotuf.f +++ /dev/null @@ -1,37 +0,0 @@ - complex function cdotuf(n,cx,incx,cy,incy) -c -c forms the dot product of two vectors. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*),cy(*),ctemp - integer i,incx,incy,ix,iy,n -c - ctemp = (0.0,0.0) - cdotuf = (0.0,0.0) - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ctemp = ctemp + cx(ix)*cy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - cdotuf = ctemp - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ctemp = ctemp + cx(i)*cy(i) - 30 continue - cdotuf = ctemp - return - end diff --git a/reference/cgbmvf.f b/reference/cgbmvf.f deleted file mode 100644 index 27ce62cb5..000000000 --- a/reference/cgbmvf.f +++ /dev/null @@ -1,450 +0,0 @@ - SUBROUTINE CGBMVF( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGBMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -* -* y := alpha*conjg( A' )*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n band matrix, with kl sub-diagonals and ku super-diagonals. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* KL - INTEGER. -* On entry, KL specifies the number of sub-diagonals of the -* matrix A. KL must satisfy 0 .le. KL. -* Unchanged on exit. -* -* KU - INTEGER. -* On entry, KU specifies the number of super-diagonals of the -* matrix A. KU must satisfy 0 .le. KU. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading ( kl + ku + 1 ) by n part of the -* array A must contain the matrix of coefficients, supplied -* column by column, with the leading diagonal of the matrix in -* row ( ku + 1 ) of the array, the first super-diagonal -* starting at position 2 in row ku, the first sub-diagonal -* starting at position 1 in row ( ku + 2 ), and so on. -* Elements in the array A that do not correspond to elements -* in the band matrix (such as the top left ku by ku triangle) -* are not referenced. -* The following program segment will transfer a band matrix -* from conventional full matrix storage to band storage: -* -* DO 20, J = 1, N -* K = KU + 1 - J -* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -* A( K + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( kl + ku + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY - LOGICAL NOCONJ, NOTRANS, XCONJ -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ).AND. - $ .NOT.LSAME( TRANS, 'O' ).AND. - $ .NOT.LSAME( TRANS, 'U' ).AND. - $ .NOT.LSAME( TRANS, 'S' ).AND. - $ .NOT.LSAME( TRANS, 'D' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( KL.LT.0 )THEN - INFO = 4 - ELSE IF( KU.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN - INFO = 8 - ELSE IF( INCX.EQ.0 )THEN - INFO = 10 - ELSE IF( INCY.EQ.0 )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* - NOCONJ = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - $ .OR. LSAME( TRANS, 'O' ) .OR. LSAME( TRANS, 'U' )) - - NOTRANS = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'R' ) - $ .OR. LSAME( TRANS, 'O' ) .OR. LSAME( TRANS, 'S' )) - - XCONJ = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - $ .OR. LSAME( TRANS, 'R' ) .OR. LSAME( TRANS, 'C' )) -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF(NOTRANS)THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the band part of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - - KUP1 = KU + 1 - - IF(XCONJ)THEN - - IF(NOTRANS)THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - K = KUP1 - J - IF( NOCONJ )THEN - DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 50 CONTINUE - ELSE - DO 55, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*CONJG(A( K + I, J )) - 55 CONTINUE - END IF - - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - K = KUP1 - J - IF( NOCONJ )THEN - DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 70 CONTINUE - ELSE - DO 75, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*CONJG(A( K + I, J )) - IY = IY + INCY - 75 CONTINUE - END IF - - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - K = KUP1 - J - IF( NOCONJ )THEN - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - ELSE - DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + CONJG( A( K + I, J ) )*X( I ) - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - IF( NOCONJ )THEN - DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + CONJG( A( K + I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 140 CONTINUE - END IF - END IF - - ELSE - - IF(NOTRANS)THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 160, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*CONJG(X( JX )) - K = KUP1 - J - IF( NOCONJ )THEN - DO 150, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 150 CONTINUE - ELSE - DO 155, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*CONJG(A( K + I, J )) - 155 CONTINUE - END IF - - END IF - JX = JX + INCX - 160 CONTINUE - ELSE - DO 180, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*CONJG(X( JX )) - IY = KY - K = KUP1 - J - IF( NOCONJ )THEN - DO 170, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 170 CONTINUE - ELSE - DO 175, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*CONJG(A( K + I, J )) - IY = IY + INCY - 175 CONTINUE - END IF - - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 180 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 210, J = 1, N - TEMP = ZERO - K = KUP1 - J - IF( NOCONJ )THEN - DO 190, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*CONJG(X( I )) - 190 CONTINUE - ELSE - DO 200, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + CONJG( A( K + I, J ) )*CONJG(X( I )) - 200 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 210 CONTINUE - ELSE - DO 240, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - IF( NOCONJ )THEN - DO 220, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*CONJG(X( IX )) - IX = IX + INCX - 220 CONTINUE - ELSE - DO 230, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + CONJG( A( K + I, J ) )*CONJG(X(IX )) - IX = IX + INCX - 230 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 240 CONTINUE - END IF - END IF - - END IF - -* - RETURN -* -* End of ZGBMV . -* - END diff --git a/reference/cgemm3mf.f b/reference/cgemm3mf.f deleted file mode 100644 index a144aa2b3..000000000 --- a/reference/cgemm3mf.f +++ /dev/null @@ -1,414 +0,0 @@ - SUBROUTINE CGEMM3MF(TRA,TRB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* .. Scalar Arguments .. - COMPLEX ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRA,TRB -* .. -* .. Array Arguments .. - COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* Purpose -* ======= -* -* CGEMM 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' or op( X ) = conjg( X' ), -* -* 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. -* -* Arguments -* ========== -* -* TRA - CHARACTER*1. -* On entry, TRA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRA = 'N' or 'n', op( A ) = A. -* -* TRA = 'T' or 't', op( A ) = A'. -* -* TRA = 'C' or 'c', op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* TRB - CHARACTER*1. -* On entry, TRB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRB = 'N' or 'n', op( B ) = B. -* -* TRB = 'T' or 't', op( B ) = B'. -* -* TRB = 'C' or 'c', op( B ) = conjg( B' ). -* -* Unchanged on exit. -* -* M - 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. -* Unchanged on exit. -* -* N - 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. -* Unchanged on exit. -* -* K - 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. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* k when TRA = 'N' or 'n', and is m otherwise. -* Before entry with TRA = '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. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is -* n when TRB = 'N' or 'n', and is k otherwise. -* Before entry with TRB = '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. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX array of 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 ). -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC CONJG,MAX -* .. -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL CONJA,CONJB,NOTA,NOTB -* .. -* .. Parameters .. - COMPLEX ONE - PARAMETER (ONE= (1.0E+0,0.0E+0)) - COMPLEX ZERO - PARAMETER (ZERO= (0.0E+0,0.0E+0)) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* conjugated or transposed, set CONJA and CONJB as true if A and -* B respectively are to be transposed but not conjugated 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(TRA,'N') - NOTB = LSAME(TRB,'N') - CONJA = LSAME(TRA,'C') - CONJB = LSAME(TRB,'C') - 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.CONJA) .AND. - + (.NOT.LSAME(TRA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. - + (.NOT.LSAME(TRB,'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('CGEMM ',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 when 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 - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE IF (CONJA) THEN -* -* Form C := alpha*conjg( A' )*B + beta*C. -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + CONJG(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 - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 150 J = 1,N - DO 140 I = 1,M - TEMP = ZERO - DO 130 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 130 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF (NOTA) THEN - IF (CONJB) THEN -* -* Form C := alpha*A*conjg( B' ) + beta*C. -* - DO 200 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 160 I = 1,M - C(I,J) = ZERO - 160 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 170 I = 1,M - C(I,J) = BETA*C(I,J) - 170 CONTINUE - END IF - DO 190 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*CONJG(B(J,L)) - DO 180 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE -* -* Form C := alpha*A*B' + beta*C -* - DO 250 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 210 I = 1,M - C(I,J) = ZERO - 210 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 220 I = 1,M - C(I,J) = BETA*C(I,J) - 220 CONTINUE - END IF - DO 240 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 230 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 230 CONTINUE - END IF - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF (CONJA) THEN - IF (CONJB) THEN -* -* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. -* - DO 280 J = 1,N - DO 270 I = 1,M - TEMP = ZERO - DO 260 L = 1,K - TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) - 260 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -* -* Form C := alpha*conjg( A' )*B' + beta*C -* - DO 310 J = 1,N - DO 300 I = 1,M - TEMP = ZERO - DO 290 L = 1,K - TEMP = TEMP + CONJG(A(L,I))*B(J,L) - 290 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF (CONJB) THEN -* -* Form C := alpha*A'*conjg( B' ) + beta*C -* - DO 340 J = 1,N - DO 330 I = 1,M - TEMP = ZERO - DO 320 L = 1,K - TEMP = TEMP + A(L,I)*CONJG(B(J,L)) - 320 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 370 J = 1,N - DO 360 I = 1,M - TEMP = ZERO - DO 350 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 350 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -* - RETURN -* -* End of CGEMM . -* - END diff --git a/reference/cgemmf.f b/reference/cgemmf.f deleted file mode 100644 index d554fd3e7..000000000 --- a/reference/cgemmf.f +++ /dev/null @@ -1,414 +0,0 @@ - SUBROUTINE CGEMMF(TRANA,TRANB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* .. Scalar Arguments .. - COMPLEX ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANA,TRANB -* .. -* .. Array Arguments .. - COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* Purpose -* ======= -* -* CGEMM 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' or op( X ) = conjg( X' ), -* -* 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. -* -* Arguments -* ========== -* -* TRANA - CHARACTER*1. -* On entry, TRANA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANA = 'N' or 'n', op( A ) = A. -* -* TRANA = 'T' or 't', op( A ) = A'. -* -* TRANA = 'C' or 'c', op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* TRANB - CHARACTER*1. -* On entry, TRANB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANB = 'N' or 'n', op( B ) = B. -* -* TRANB = 'T' or 't', op( B ) = B'. -* -* TRANB = 'C' or 'c', op( B ) = conjg( B' ). -* -* Unchanged on exit. -* -* M - 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. -* Unchanged on exit. -* -* N - 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. -* Unchanged on exit. -* -* K - 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. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* k when TRANA = 'N' or 'n', and is m otherwise. -* Before entry with TRANA = '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. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is -* n when TRANB = 'N' or 'n', and is k otherwise. -* Before entry with TRANB = '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. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX array of 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 ). -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC CONJG,MAX -* .. -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL CONJA,CONJB,NOTA,NOTB -* .. -* .. Parameters .. - COMPLEX ONE - PARAMETER (ONE= (1.0E+0,0.0E+0)) - COMPLEX ZERO - PARAMETER (ZERO= (0.0E+0,0.0E+0)) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* conjugated or transposed, set CONJA and CONJB as true if A and -* B respectively are to be transposed but not conjugated 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(TRANA,'N') - NOTB = LSAME(TRANB,'N') - CONJA = LSAME(TRANA,'C') - CONJB = LSAME(TRANB,'C') - 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.CONJA) .AND. - + (.NOT.LSAME(TRANA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. - + (.NOT.LSAME(TRANB,'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('CGEMM ',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 when 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 - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE IF (CONJA) THEN -* -* Form C := alpha*conjg( A' )*B + beta*C. -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + CONJG(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 - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 150 J = 1,N - DO 140 I = 1,M - TEMP = ZERO - DO 130 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 130 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF (NOTA) THEN - IF (CONJB) THEN -* -* Form C := alpha*A*conjg( B' ) + beta*C. -* - DO 200 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 160 I = 1,M - C(I,J) = ZERO - 160 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 170 I = 1,M - C(I,J) = BETA*C(I,J) - 170 CONTINUE - END IF - DO 190 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*CONJG(B(J,L)) - DO 180 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE -* -* Form C := alpha*A*B' + beta*C -* - DO 250 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 210 I = 1,M - C(I,J) = ZERO - 210 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 220 I = 1,M - C(I,J) = BETA*C(I,J) - 220 CONTINUE - END IF - DO 240 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 230 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 230 CONTINUE - END IF - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF (CONJA) THEN - IF (CONJB) THEN -* -* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. -* - DO 280 J = 1,N - DO 270 I = 1,M - TEMP = ZERO - DO 260 L = 1,K - TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) - 260 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -* -* Form C := alpha*conjg( A' )*B' + beta*C -* - DO 310 J = 1,N - DO 300 I = 1,M - TEMP = ZERO - DO 290 L = 1,K - TEMP = TEMP + CONJG(A(L,I))*B(J,L) - 290 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF (CONJB) THEN -* -* Form C := alpha*A'*conjg( B' ) + beta*C -* - DO 340 J = 1,N - DO 330 I = 1,M - TEMP = ZERO - DO 320 L = 1,K - TEMP = TEMP + A(L,I)*CONJG(B(J,L)) - 320 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 370 J = 1,N - DO 360 I = 1,M - TEMP = ZERO - DO 350 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 350 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -* - RETURN -* -* End of CGEMM . -* - END diff --git a/reference/cgemvf.f b/reference/cgemvf.f deleted file mode 100644 index d3a1d9e7c..000000000 --- a/reference/cgemvf.f +++ /dev/null @@ -1,332 +0,0 @@ - SUBROUTINE CGEMVF ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -* -* y := alpha*conjg( A' )*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - COMPLEX array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY - LOGICAL NOCONJ, NOTRANS, XCONJ -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ).AND. - $ .NOT.LSAME( TRANS, 'O' ).AND. - $ .NOT.LSAME( TRANS, 'U' ).AND. - $ .NOT.LSAME( TRANS, 'S' ).AND. - $ .NOT.LSAME( TRANS, 'D' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* - NOCONJ = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - $ .OR. LSAME( TRANS, 'O' ) .OR. LSAME( TRANS, 'U' )) - - NOTRANS = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'R' ) - $ .OR. LSAME( TRANS, 'O' ) .OR. LSAME( TRANS, 'S' )) - - XCONJ = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - $ .OR. LSAME( TRANS, 'R' ) .OR. LSAME( TRANS, 'C' )) -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF(NOTRANS)THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - - IF(NOTRANS)THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF (XCONJ) THEN - TEMP = ALPHA*X( JX ) - ELSE - TEMP = ALPHA*CONJG(X( JX )) - ENDIF - IF (NOCONJ) THEN - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - ELSE - DO 55, I = 1, M - Y( I ) = Y( I ) + TEMP*CONJG(A( I, J )) - 55 CONTINUE - ENDIF - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF (XCONJ) THEN - TEMP = ALPHA*X( JX ) - ELSE - TEMP = ALPHA*CONJG(X( JX )) - ENDIF - IY = KY - IF (NOCONJ) THEN - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - ELSE - DO 75, I = 1, M - Y( IY ) = Y( IY ) + TEMP* CONJG(A( I, J )) - IY = IY + INCY - 75 CONTINUE - ENDIF - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - IF( NOCONJ )THEN - DO 90, I = 1, M - IF (XCONJ) THEN - TEMP = TEMP + A( I, J )*X( I ) - ELSE - TEMP = TEMP + A( I, J )*CONJG(X( I )) - ENDIF - 90 CONTINUE - ELSE - DO 100, I = 1, M - IF (XCONJ) THEN - TEMP = TEMP + CONJG( A( I, J ) )*X( I ) - ELSE - TEMP = TEMP + CONJG( A( I, J ) )*CONJG(X( I )) - ENDIF - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - IF( NOCONJ )THEN - DO 120, I = 1, M - IF (XCONJ) THEN - TEMP = TEMP + A( I, J )*X( IX ) - ELSE - TEMP = TEMP + A( I, J )*CONJG(X( IX )) - ENDIF - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = 1, M - IF (XCONJ) THEN - TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) - ELSE - TEMP = TEMP + CONJG( A( I, J ) )*CONJG(X( IX )) - ENDIF - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 140 CONTINUE - END IF - END IF -* - RETURN -* -* End of CGEMV . -* - END - diff --git a/reference/cgercf.f b/reference/cgercf.f deleted file mode 100644 index 9b4b41bbd..000000000 --- a/reference/cgercf.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE CGERCF ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CGERC performs the rank 1 operation -* -* A := alpha*x*conjg( y' ) + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CGERC ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( Y( JY ) ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( Y( JY ) ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of CGERC . -* - END diff --git a/reference/cgeruf.f b/reference/cgeruf.f deleted file mode 100644 index 72e6969ed..000000000 --- a/reference/cgeruf.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE CGERUF ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CGERU performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CGERU ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of CGERU . -* - END diff --git a/reference/cgesvf.f b/reference/cgesvf.f deleted file mode 100644 index 654405934..000000000 --- a/reference/cgesvf.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE CGESVF( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* CGESV computes the solution to a complex system of linear equations -* A * X = B, -* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as -* A = P * L * U, -* where P is a permutation matrix, L is unit lower triangular, and U is -* upper triangular. The factored form of A is then used to solve the -* system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the N-by-N coefficient matrix A. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) COMPLEX array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS matrix of right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, so the solution could not be computed. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL CGETRF, CGETRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL CGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL CGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of CGESV -* - END diff --git a/reference/cgetf2f.f b/reference/cgetf2f.f deleted file mode 100644 index f40675028..000000000 --- a/reference/cgetf2f.f +++ /dev/null @@ -1,136 +0,0 @@ - SUBROUTINE CGETF2F( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE, ZERO - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), - $ ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER ICAMAX - EXTERNAL ICAMAX -* .. -* .. External Subroutines .. - EXTERNAL CGERU, CSCAL, CSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + ICAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL CSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL CSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL CGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), - $ LDA, A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of CGETF2 -* - END diff --git a/reference/cgetrff.f b/reference/cgetrff.f deleted file mode 100644 index 2935c5d06..000000000 --- a/reference/cgetrff.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE CGETRFF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL CGEMM, CGETF2, CLASWP, CTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 64 - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL CGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL CGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL CLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL CLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL CGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of CGETRF -* - END diff --git a/reference/cgetrsf.f b/reference/cgetrsf.f deleted file mode 100644 index c4f0079c1..000000000 --- a/reference/cgetrsf.f +++ /dev/null @@ -1,150 +0,0 @@ - SUBROUTINE CGETRSF( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* CGETRS solves a system of linear equations -* A * X = B, A**T * X = B, or A**H * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by CGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T * X = B (Transpose) -* = 'C': A**H * X = B (Conjugate transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) COMPLEX array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by CGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from CGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) COMPLEX array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL CLASWP, CTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) .OR. LSAME(TRANS, 'R') - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL CTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL CTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B or A**H * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL CTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL CTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, - $ LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of CGETRS -* - END diff --git a/reference/chbmvf.f b/reference/chbmvf.f deleted file mode 100644 index 85285c4b8..000000000 --- a/reference/chbmvf.f +++ /dev/null @@ -1,309 +0,0 @@ - SUBROUTINE CHBMVF( UPLO, N, K, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CHBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian band matrix, with k super-diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the band matrix A is being supplied as -* follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* being supplied. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* being supplied. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of super-diagonals of the -* matrix A. K must satisfy 0 .le. K. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the hermitian matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a hermitian band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the hermitian matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a hermitian band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - COMPLEX array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, MIN, REAL -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( K.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array A -* are accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + CONJG( A( L + I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*REAL( A( KPLUS1, J ) ) - $ + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + CONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*REAL( A( KPLUS1, J ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*REAL( A( 1, J ) ) - L = 1 - J - DO 90, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + CONJG( A( L + I, J ) )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*REAL( A( 1, J ) ) - L = 1 - J - IX = JX - IY = JY - DO 110, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + CONJG( A( L + I, J ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of CHBMV . -* - END diff --git a/reference/chemm3mf.f b/reference/chemm3mf.f deleted file mode 100644 index 7fd2e6e22..000000000 --- a/reference/chemm3mf.f +++ /dev/null @@ -1,304 +0,0 @@ - SUBROUTINE CHEMM3MF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX ALPHA, BETA -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* CHEMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is an hermitian matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the hermitian matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the hermitian matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* hermitian matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* hermitian matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP1, TEMP2 -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHEMM3M', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*CONJG( A( K, I ) ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*CONJG( A( K, I ) ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*REAL( A( J, J ) ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*CONJG( A( J, K ) ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*CONJG( A( J, K ) ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of CHEMM . -* - END diff --git a/reference/chemmf.f b/reference/chemmf.f deleted file mode 100644 index ccb9b0a6a..000000000 --- a/reference/chemmf.f +++ /dev/null @@ -1,304 +0,0 @@ - SUBROUTINE CHEMMF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX ALPHA, BETA -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* CHEMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is an hermitian matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the hermitian matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the hermitian matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* hermitian matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* hermitian matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP1, TEMP2 -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHEMM3M', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*CONJG( A( K, I ) ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*CONJG( A( K, I ) ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*REAL( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*REAL( A( J, J ) ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*CONJG( A( J, K ) ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*CONJG( A( J, K ) ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of CHEMM . -* - END diff --git a/reference/chemvf.f b/reference/chemvf.f deleted file mode 100644 index 6ce567d83..000000000 --- a/reference/chemvf.f +++ /dev/null @@ -1,349 +0,0 @@ - SUBROUTINE CHEMVF ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CHEMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ).AND. - $ .NOT.LSAME( UPLO, 'V' ).AND. - $ .NOT.LSAME( UPLO, 'M' ))THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - - - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + CONJG( A( I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*REAL( A( J, J ) ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + CONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*REAL( A( J, J ) ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - RETURN - ENDIF - - IF( LSAME( UPLO, 'L' ) )THEN -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*REAL( A( J, J ) ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + CONJG( A( I, J ) )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*REAL( A( J, J ) ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + CONJG( A( I, J ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - RETURN - END IF - - IF( LSAME( UPLO, 'V' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 160, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 150, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1* CONJG(A( I, J )) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 150 CONTINUE - Y( J ) = Y( J ) + TEMP1*REAL( A( J, J ) ) + ALPHA*TEMP2 - 160 CONTINUE - ELSE - JX = KX - JY = KY - DO 180, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 170, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1* CONJG(A( I, J )) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 170 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*REAL( A( J, J ) ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 180 CONTINUE - END IF - RETURN - ENDIF - - - IF( LSAME( UPLO, 'M' ) )THEN -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 200, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*REAL( A( J, J ) ) - DO 190, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*CONJG(A( I, J )) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 190 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 200 CONTINUE - ELSE - JX = KX - JY = KY - DO 220, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*REAL( A( J, J ) ) - IX = JX - IY = JY - DO 210, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*CONJG(A( I, J )) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 210 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 220 CONTINUE - END IF - RETURN - END IF - -* -* -* End of CHEMV . -* - END diff --git a/reference/cher2f.f b/reference/cher2f.f deleted file mode 100644 index 096709a54..000000000 --- a/reference/cher2f.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE CHER2F ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CHER2 performs the hermitian rank 2 operation -* -* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n hermitian matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHER2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( J ) ) - TEMP2 = CONJG( ALPHA*X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - A( J, J ) = REAL( A( J, J ) ) + - $ REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( JY ) ) - TEMP2 = CONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - A( J, J ) = REAL( A( J, J ) ) + - $ REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( J ) ) - TEMP2 = CONJG( ALPHA*X( J ) ) - A( J, J ) = REAL( A( J, J ) ) + - $ REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( JY ) ) - TEMP2 = CONJG( ALPHA*X( JX ) ) - A( J, J ) = REAL( A( J, J ) ) + - $ REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of CHER2 . -* - END diff --git a/reference/cher2kf.f b/reference/cher2kf.f deleted file mode 100644 index 935c92d5c..000000000 --- a/reference/cher2kf.f +++ /dev/null @@ -1,371 +0,0 @@ - SUBROUTINE CHER2KF( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - REAL BETA - COMPLEX ALPHA -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* CHER2K performs one of the hermitian rank 2k operations -* -* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, -* -* or -* -* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, -* -* where alpha and beta are scalars with beta real, C is an n by n -* hermitian matrix and A and B are n by k matrices in the first case -* and k by n matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + -* conjg( alpha )*B*conjg( A' ) + -* beta*C. -* -* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + -* conjg( alpha )*conjg( B' )*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'C' or 'c', K specifies the number of rows of the -* matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. -* Ed Anderson, Cray Research Inc. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX TEMP1, TEMP2 -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHER2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.REAL( ZERO ) )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.REAL( ZERO ) )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - C( J, J ) = BETA*REAL( C( J, J ) ) - DO 70, I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + -* C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.REAL( ZERO ) )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - ELSE - C( J, J ) = REAL( C( J, J ) ) - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( B( J, L ) ) - TEMP2 = CONJG( ALPHA*A( J, L ) ) - DO 110, I = 1, J - 1 - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - C( J, J ) = REAL( C( J, J ) ) + - $ REAL( A( J, L )*TEMP1 + - $ B( J, L )*TEMP2 ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.REAL( ZERO ) )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - ELSE - C( J, J ) = REAL( C( J, J ) ) - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( B( J, L ) ) - TEMP2 = CONJG( ALPHA*A( J, L ) ) - DO 160, I = J + 1, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - C( J, J ) = REAL( C( J, J ) ) + - $ REAL( A( J, L )*TEMP1 + - $ B( J, L )*TEMP2 ) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + -* C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + CONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + CONJG( B( L, I ) )*A( L, J ) - 190 CONTINUE - IF( I.EQ.J )THEN - IF( BETA.EQ.REAL( ZERO ) )THEN - C( J, J ) = REAL( ALPHA *TEMP1 + - $ CONJG( ALPHA )*TEMP2 ) - ELSE - C( J, J ) = BETA*REAL( C( J, J ) ) + - $ REAL( ALPHA *TEMP1 + - $ CONJG( ALPHA )*TEMP2 ) - END IF - ELSE - IF( BETA.EQ.REAL( ZERO ) )THEN - C( I, J ) = ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 - END IF - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + CONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + CONJG( B( L, I ) )*A( L, J ) - 220 CONTINUE - IF( I.EQ.J )THEN - IF( BETA.EQ.REAL( ZERO ) )THEN - C( J, J ) = REAL( ALPHA *TEMP1 + - $ CONJG( ALPHA )*TEMP2 ) - ELSE - C( J, J ) = BETA*REAL( C( J, J ) ) + - $ REAL( ALPHA *TEMP1 + - $ CONJG( ALPHA )*TEMP2 ) - END IF - ELSE - IF( BETA.EQ.REAL( ZERO ) )THEN - C( I, J ) = ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + CONJG( ALPHA )*TEMP2 - END IF - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of CHER2K. -* - END diff --git a/reference/cherf.f b/reference/cherf.f deleted file mode 100644 index 748ae565c..000000000 --- a/reference/cherf.f +++ /dev/null @@ -1,212 +0,0 @@ - SUBROUTINE CHERF ( UPLO, N, ALPHA, X, INCX, A, LDA ) -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CHER performs the hermitian rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n hermitian matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, REAL -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.REAL( ZERO ) ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - A( J, J ) = REAL( A( J, J ) ) + REAL( X( J )*TEMP ) - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( JX ) ) - IX = KX - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - A( J, J ) = REAL( A( J, J ) ) + REAL( X( JX )*TEMP ) - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( J ) ) - A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( J ) ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( JX ) ) - A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( JX ) ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - A( I, J ) = A( I, J ) + X( IX )*TEMP - 70 CONTINUE - ELSE - A( J, J ) = REAL( A( J, J ) ) - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of CHER . -* - END diff --git a/reference/cherkf.f b/reference/cherkf.f deleted file mode 100644 index e3d0157e3..000000000 --- a/reference/cherkf.f +++ /dev/null @@ -1,328 +0,0 @@ - SUBROUTINE CHERKF ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - REAL ALPHA, BETA -* .. Array Arguments .. - COMPLEX A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* CHERK performs one of the hermitian rank k operations -* -* C := alpha*A*conjg( A' ) + beta*C, -* -* or -* -* C := alpha*conjg( A' )*A + beta*C, -* -* where alpha and beta are real scalars, C is an n by n hermitian -* matrix and A is an n by k matrix in the first case and a k by n -* matrix in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'C' or 'c', K specifies the number of rows of the -* matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -- Modified 8-Nov-93 to set C(J,J) to REAL( C(J,J) ) when BETA = 1. -* Ed Anderson, Cray Research Inc. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CMPLX, CONJG, MAX, REAL -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - REAL RTEMP - COMPLEX TEMP -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHERK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - C( J, J ) = BETA*REAL( C( J, J ) ) - DO 70, I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*conjg( A' ) + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*REAL( C( J, J ) ) - ELSE - C( J, J ) = REAL( C( J, J ) ) - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.CMPLX( ZERO ) )THEN - TEMP = ALPHA*CONJG( A( J, L ) ) - DO 110, I = 1, J - 1 - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - C( J, J ) = REAL( C( J, J ) ) + - $ REAL( TEMP*A( I, L ) ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - C( J, J ) = BETA*REAL( C( J, J ) ) - DO 150, I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - ELSE - C( J, J ) = REAL( C( J, J ) ) - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.CMPLX( ZERO ) )THEN - TEMP = ALPHA*CONJG( A( J, L ) ) - C( J, J ) = REAL( C( J, J ) ) + - $ REAL( TEMP*A( J, L ) ) - DO 160, I = J + 1, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*conjg( A' )*A + beta*C. -* - IF( UPPER )THEN - DO 220, J = 1, N - DO 200, I = 1, J - 1 - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + CONJG( A( L, I ) )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - RTEMP = ZERO - DO 210, L = 1, K - RTEMP = RTEMP + CONJG( A( L, J ) )*A( L, J ) - 210 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*REAL( C( J, J ) ) - END IF - 220 CONTINUE - ELSE - DO 260, J = 1, N - RTEMP = ZERO - DO 230, L = 1, K - RTEMP = RTEMP + CONJG( A( L, J ) )*A( L, J ) - 230 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*REAL( C( J, J ) ) - END IF - DO 250, I = J + 1, N - TEMP = ZERO - DO 240, L = 1, K - TEMP = TEMP + CONJG( A( L, I ) )*A( L, J ) - 240 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 250 CONTINUE - 260 CONTINUE - END IF - END IF -* - RETURN -* -* End of CHERK . -* - END diff --git a/reference/chpmvf.f b/reference/chpmvf.f deleted file mode 100644 index 9f65105d6..000000000 --- a/reference/chpmvf.f +++ /dev/null @@ -1,270 +0,0 @@ - SUBROUTINE CHPMVF( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CHPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - COMPLEX array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, REAL -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + CONJG( AP( K ) )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*REAL( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + CONJG( AP( K ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*REAL( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*REAL( AP( KK ) ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + CONJG( AP( K ) )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*REAL( AP( KK ) ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + CONJG( AP( K ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of CHPMV . -* - END diff --git a/reference/chpr2f.f b/reference/chpr2f.f deleted file mode 100644 index 64f8fe96c..000000000 --- a/reference/chpr2f.f +++ /dev/null @@ -1,251 +0,0 @@ - SUBROUTINE CHPR2F( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - COMPLEX ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CHPR2 performs the hermitian rank 2 operation -* -* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, REAL -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( J ) ) - TEMP2 = CONJG( ALPHA*X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) + - $ REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( JY ) ) - TEMP2 = CONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) + - $ REAL( X( JX )*TEMP1 + - $ Y( JY )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( J ) ) - TEMP2 = CONJG( ALPHA*X( J ) ) - AP( KK ) = REAL( AP( KK ) ) + - $ REAL( X( J )*TEMP1 + Y( J )*TEMP2 ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = REAL( AP( KK ) ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*CONJG( Y( JY ) ) - TEMP2 = CONJG( ALPHA*X( JX ) ) - AP( KK ) = REAL( AP( KK ) ) + - $ REAL( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - AP( KK ) = REAL( AP( KK ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of CHPR2 . -* - END diff --git a/reference/chprf.f b/reference/chprf.f deleted file mode 100644 index 6d1d380ca..000000000 --- a/reference/chprf.f +++ /dev/null @@ -1,217 +0,0 @@ - SUBROUTINE CHPRF ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CHPR performs the hermitian rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, REAL -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CHPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.REAL( ZERO ) ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - $ + REAL( X( J )*TEMP ) - ELSE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( JX ) ) - IX = KX - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - $ + REAL( X( JX )*TEMP ) - ELSE - AP( KK + J - 1 ) = REAL( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( J ) ) - AP( KK ) = REAL( AP( KK ) ) + REAL( TEMP*X( J ) ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = REAL( AP( KK ) ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*CONJG( X( JX ) ) - AP( KK ) = REAL( AP( KK ) ) + REAL( TEMP*X( JX ) ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - AP( K ) = AP( K ) + X( IX )*TEMP - 70 CONTINUE - ELSE - AP( KK ) = REAL( AP( KK ) ) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of CHPR . -* - END diff --git a/reference/claswpf.f b/reference/claswpf.f deleted file mode 100644 index 4d47e4f75..000000000 --- a/reference/claswpf.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE CLASWPF( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - COMPLEX TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of CLASWP -* - END diff --git a/reference/clauu2f.f b/reference/clauu2f.f deleted file mode 100644 index 4bb87250c..000000000 --- a/reference/clauu2f.f +++ /dev/null @@ -1,143 +0,0 @@ - SUBROUTINE CLAUU2F( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CLAUU2 computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the unblocked form of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - REAL AII -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX CDOTC - EXTERNAL LSAME, CDOTC -* .. -* .. External Subroutines .. - EXTERNAL CGEMV, CLACGV, CSSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC CMPLX, MAX, REAL -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CLAUU2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = AII*AII + REAL( CDOTC( N-I, A( I, I+1 ), LDA, - $ A( I, I+1 ), LDA ) ) - CALL CLACGV( N-I, A( I, I+1 ), LDA ) - CALL CGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, CMPLX( AII ), - $ A( 1, I ), 1 ) - CALL CLACGV( N-I, A( I, I+1 ), LDA ) - ELSE - CALL CSSCAL( I, AII, A( 1, I ), 1 ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = AII*AII + REAL( CDOTC( N-I, A( I+1, I ), 1, - $ A( I+1, I ), 1 ) ) - CALL CLACGV( I-1, A( I, 1 ), LDA ) - CALL CGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ A( I+1, 1 ), LDA, A( I+1, I ), 1, - $ CMPLX( AII ), A( I, 1 ), LDA ) - CALL CLACGV( I-1, A( I, 1 ), LDA ) - ELSE - CALL CSSCAL( I, AII, A( I, 1 ), LDA ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of CLAUU2 -* - END diff --git a/reference/clauumf.f b/reference/clauumf.f deleted file mode 100644 index 9b57fe11d..000000000 --- a/reference/clauumf.f +++ /dev/null @@ -1,161 +0,0 @@ - SUBROUTINE CLAUUMF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CLAUUM computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the blocked form of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) - COMPLEX CONE - PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL CGEMM, CHERK, CLAUU2, CTRMM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CLAUUM', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 128 -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL CLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Non-unit', I-1, IB, CONE, A( I, I ), LDA, - $ A( 1, I ), LDA ) - CALL CLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ), - $ LDA, A( I, I+IB ), LDA, CONE, A( 1, I ), - $ LDA ) - CALL CHERK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL CTRMM( 'Left', 'Lower', 'Conjugate transpose', - $ 'Non-unit', IB, I-1, CONE, A( I, I ), LDA, - $ A( I, 1 ), LDA ) - CALL CLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL CGEMM( 'Conjugate transpose', 'No transpose', IB, - $ I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA ) - CALL CHERK( 'Lower', 'Conjugate transpose', IB, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE, - $ A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF -* - RETURN -* -* End of CLAUUM -* - END diff --git a/reference/cpotf2f.f b/reference/cpotf2f.f deleted file mode 100644 index 2b451ccd7..000000000 --- a/reference/cpotf2f.f +++ /dev/null @@ -1,175 +0,0 @@ - SUBROUTINE CPOTF2F( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CPOTF2 computes the Cholesky factorization of a complex Hermitian -* positive definite matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* Hermitian matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) - COMPLEX CONE - PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - REAL AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX CDOTC - EXTERNAL LSAME, CDOTC -* .. -* .. External Subroutines .. - EXTERNAL CGEMV, CLACGV, CSSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, REAL, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = REAL( A( J, J ) ) - CDOTC( J-1, A( 1, J ), 1, - $ A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL CLACGV( J-1, A( 1, J ), 1 ) - CALL CGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA ) - CALL CLACGV( J-1, A( 1, J ), 1 ) - CALL CSSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = REAL( A( J, J ) ) - CDOTC( J-1, A( J, 1 ), LDA, - $ A( J, 1 ), LDA ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL CLACGV( J-1, A( J, 1 ), LDA ) - CALL CGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 ) - CALL CLACGV( J-1, A( J, 1 ), LDA ) - CALL CSSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of CPOTF2 -* - END diff --git a/reference/cpotrff.f b/reference/cpotrff.f deleted file mode 100644 index 696de862a..000000000 --- a/reference/cpotrff.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE CPOTRFF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CPOTRF computes the Cholesky factorization of a complex Hermitian -* positive definite matrix A. -* -* The factorization has the form -* A = U**H * U, if UPLO = 'U', or -* A = L * L**H, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**H*U or A = L*L**H. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - COMPLEX CONE - PARAMETER ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL CGEMM, CHERK, CPOTF2, CTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 56 - - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL CPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL CHERK( 'Upper', 'Conjugate transpose', JB, J-1, - $ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL CPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL CGEMM( 'Conjugate transpose', 'No transpose', JB, - $ N-J-JB+1, J-1, -CONE, A( 1, J ), LDA, - $ A( 1, J+JB ), LDA, CONE, A( J, J+JB ), - $ LDA ) - CALL CTRSM( 'Left', 'Upper', 'Conjugate transpose', - $ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ), - $ LDA, A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL CHERK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL CPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL CGEMM( 'No transpose', 'Conjugate transpose', - $ N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ), - $ LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ), - $ LDA ) - CALL CTRSM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ), - $ LDA, A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of CPOTRF -* - END diff --git a/reference/cpotrif.f b/reference/cpotrif.f deleted file mode 100644 index e14b28772..000000000 --- a/reference/cpotrif.f +++ /dev/null @@ -1,96 +0,0 @@ - SUBROUTINE CPOTRIF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CPOTRI computes the inverse of a complex Hermitian positive definite -* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H -* computed by CPOTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the triangular factor U or L from the Cholesky -* factorization A = U**H*U or A = L*L**H, as computed by -* CPOTRF. -* On exit, the upper or lower triangle of the (Hermitian) -* inverse of A, overwriting the input factor U or L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the (i,i) element of the factor U or L is -* zero, and the inverse could not be computed. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL CLAUUM, CTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CPOTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Invert the triangular Cholesky factor U or L. -* - CALL CTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* -* Form inv(U)*inv(U)' or inv(L)'*inv(L). -* - CALL CLAUUM( UPLO, N, A, LDA, INFO ) -* - RETURN -* -* End of CPOTRI -* - END diff --git a/reference/crotgf.f b/reference/crotgf.f deleted file mode 100644 index 619513370..000000000 --- a/reference/crotgf.f +++ /dev/null @@ -1,20 +0,0 @@ - subroutine crotgf(ca,cb,c,s) - complex ca,cb,s - real c - real norm,scale - complex alpha - if (cabs(ca) .ne. 0.) go to 10 - c = 0. - s = (1.,0.) - ca = cb - go to 20 - 10 continue - scale = cabs(ca) + cabs(cb) - norm = scale * sqrt((cabs(ca/scale))**2 + (cabs(cb/scale))**2) - alpha = ca /cabs(ca) - c = cabs(ca) / norm - s = alpha * conjg(cb) / norm - ca = alpha * norm - 20 continue - return - end diff --git a/reference/csbmvf.f b/reference/csbmvf.f deleted file mode 100644 index e635af8b2..000000000 --- a/reference/csbmvf.f +++ /dev/null @@ -1,306 +0,0 @@ - SUBROUTINE CSBMVF(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, INCY, K, LDA, N - COMPLEX ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CSBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric band matrix, with k super-diagonals. -* -* Arguments -* ========== -* -* UPLO - CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the band matrix A is being supplied as -* follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* being supplied. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* being supplied. -* -* Unchanged on exit. -* -* N - INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER -* On entry, K specifies the number of super-diagonals of the -* matrix A. K must satisfy 0 .le. K. -* Unchanged on exit. -* -* ALPHA - COMPLEX -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array, dimension( LDA, N ) -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - COMPLEX array, dimension at least -* ( 1 + ( N - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L - COMPLEX TEMP1, TEMP2 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( K.LT.0 ) THEN - INFO = 3 - ELSE IF( LDA.LT.( K+1 ) ) THEN - INFO = 6 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 8 - ELSE IF( INCY.EQ.0 ) THEN - INFO = 11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CSBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 ) THEN - KX = 1 - ELSE - KX = 1 - ( N-1 )*INCX - END IF - IF( INCY.GT.0 ) THEN - KY = 1 - ELSE - KY = 1 - ( N-1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array A -* are accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE ) THEN - IF( INCY.EQ.1 ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 10 I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO ) THEN - DO 30 I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 60 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50 I = MAX( 1, J-K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L+I, J ) - TEMP2 = TEMP2 + A( L+I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70 I = MAX( 1, J-K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L+I, J ) - TEMP2 = TEMP2 + A( L+I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K ) THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 100 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( 1, J ) - L = 1 - J - DO 90 I = J + 1, MIN( N, J+K ) - Y( I ) = Y( I ) + TEMP1*A( L+I, J ) - TEMP2 = TEMP2 + A( L+I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) - L = 1 - J - IX = JX - IY = JY - DO 110 I = J + 1, MIN( N, J+K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L+I, J ) - TEMP2 = TEMP2 + A( L+I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of CSBMV -* - END diff --git a/reference/cscalf.f b/reference/cscalf.f deleted file mode 100644 index 714dc4230..000000000 --- a/reference/cscalf.f +++ /dev/null @@ -1,28 +0,0 @@ - subroutine cscalf(n,ca,cx,incx) -c -c scales a vector by a constant. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex ca,cx(*) - integer i,incx,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - cx(i) = ca*cx(i) - 10 continue - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - cx(i) = ca*cx(i) - 30 continue - return - end diff --git a/reference/cspmvf.f b/reference/cspmvf.f deleted file mode 100644 index e32b4904d..000000000 --- a/reference/cspmvf.f +++ /dev/null @@ -1,264 +0,0 @@ - SUBROUTINE CSPMVF(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, INCY, N - COMPLEX ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CSPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix, supplied in packed form. -* -* Arguments -* ========== -* -* UPLO (input) CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N (input) INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA (input) COMPLEX -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP (input) COMPLEX array, dimension at least -* ( ( N*( N + 1 ) )/2 ). -* Before entry, with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry, with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Unchanged on exit. -* -* X (input) COMPLEX array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the N- -* element vector x. -* Unchanged on exit. -* -* INCX (input) INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA (input) COMPLEX -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y (input/output) COMPLEX array, dimension at least -* ( 1 + ( N - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY (input) INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY - COMPLEX TEMP1, TEMP2 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 6 - ELSE IF( INCY.EQ.0 ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CSPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 ) THEN - KX = 1 - ELSE - KX = 1 - ( N-1 )*INCX - END IF - IF( INCY.GT.0 ) THEN - KY = 1 - ELSE - KY = 1 - ( N-1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE ) THEN - IF( INCY.EQ.1 ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 10 I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO ) THEN - DO 30 I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 60 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50 I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 100 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*AP( KK ) - K = KK + 1 - DO 90 I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N-J+1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*AP( KK ) - IX = JX - IY = JY - DO 110 K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N-J+1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of CSPMV -* - END diff --git a/reference/cspr2f.f b/reference/cspr2f.f deleted file mode 100644 index 8ba35f5f2..000000000 --- a/reference/cspr2f.f +++ /dev/null @@ -1,229 +0,0 @@ - SUBROUTINE CSPR2F( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - COMPLEX*8 ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*8 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SSPR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*8 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*8 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*8 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX*8 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*8 ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - COMPLEX*8 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSPR2 . -* - END diff --git a/reference/csprf.f b/reference/csprf.f deleted file mode 100644 index 9010f0c2e..000000000 --- a/reference/csprf.f +++ /dev/null @@ -1,213 +0,0 @@ - SUBROUTINE CSPRF( UPLO, N, ALPHA, X, INCX, AP ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, N - COMPLEX ALPHA -* .. -* .. Array Arguments .. - COMPLEX AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CSPR performs the symmetric rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a complex scalar, x is an n element vector and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Arguments -* ========== -* -* UPLO (input) CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N (input) INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA (input) COMPLEX -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X (input) COMPLEX array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the N- -* element vector x. -* Unchanged on exit. -* -* INCX (input) INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP (input/output) COMPLEX array, dimension at least -* ( ( N*( N + 1 ) )/2 ). -* Before entry, with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry, with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, J, JX, K, KK, KX - COMPLEX TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CSPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 ) THEN - KX = 1 - ( N-1 )*INCX - ELSE IF( INCX.NE.1 ) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 ) THEN - DO 20 J = 1, N - IF( X( J ).NE.ZERO ) THEN - TEMP = ALPHA*X( J ) - K = KK - DO 10 I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - AP( KK+J-1 ) = AP( KK+J-1 ) + X( J )*TEMP - ELSE - AP( KK+J-1 ) = AP( KK+J-1 ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1, N - IF( X( JX ).NE.ZERO ) THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30 K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - AP( KK+J-1 ) = AP( KK+J-1 ) + X( JX )*TEMP - ELSE - AP( KK+J-1 ) = AP( KK+J-1 ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 ) THEN - DO 60 J = 1, N - IF( X( J ).NE.ZERO ) THEN - TEMP = ALPHA*X( J ) - AP( KK ) = AP( KK ) + TEMP*X( J ) - K = KK + 1 - DO 50 I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = AP( KK ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1, N - IF( X( JX ).NE.ZERO ) THEN - TEMP = ALPHA*X( JX ) - AP( KK ) = AP( KK ) + TEMP*X( JX ) - IX = JX - DO 70 K = KK + 1, KK + N - J - IX = IX + INCX - AP( K ) = AP( K ) + X( IX )*TEMP - 70 CONTINUE - ELSE - AP( KK ) = AP( KK ) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of CSPR -* - END diff --git a/reference/csrotf.f b/reference/csrotf.f deleted file mode 100644 index 1ecdb0a5f..000000000 --- a/reference/csrotf.f +++ /dev/null @@ -1,38 +0,0 @@ - subroutine csrotf (n,cx,incx,cy,incy,c,s) -c -c applies a plane rotation, where the cos and sin (c and s) are real -c and the vectors cx and cy are complex. -c jack dongarra, linpack, 3/11/78. -c - complex cx(1),cy(1),ctemp - real c,s - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ctemp = c*cx(ix) + s*cy(iy) - cy(iy) = c*cy(iy) - s*cx(ix) - cx(ix) = ctemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ctemp = c*cx(i) + s*cy(i) - cy(i) = c*cy(i) - s*cx(i) - cx(i) = ctemp - 30 continue - return - end diff --git a/reference/csscalf.f b/reference/csscalf.f deleted file mode 100644 index 099d519b6..000000000 --- a/reference/csscalf.f +++ /dev/null @@ -1,29 +0,0 @@ - subroutine csscalf(n,sa,cx,incx) -c -c scales a complex vector by a real constant. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*) - real sa - integer i,incx,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - cx(i) = cmplx(sa*real(cx(i)),sa*aimag(cx(i))) - 10 continue - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - cx(i) = cmplx(sa*real(cx(i)),sa*aimag(cx(i))) - 30 continue - return - end diff --git a/reference/cswapf.f b/reference/cswapf.f deleted file mode 100644 index 39683b68c..000000000 --- a/reference/cswapf.f +++ /dev/null @@ -1,36 +0,0 @@ - subroutine cswapf (n,cx,incx,cy,incy) -c -c interchanges two vectors. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*),cy(*),ctemp - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ctemp = cx(ix) - cx(ix) = cy(iy) - cy(iy) = ctemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 - 20 do 30 i = 1,n - ctemp = cx(i) - cx(i) = cy(i) - cy(i) = ctemp - 30 continue - return - end diff --git a/reference/csymm3mf.f b/reference/csymm3mf.f deleted file mode 100644 index 2640a18b7..000000000 --- a/reference/csymm3mf.f +++ /dev/null @@ -1,296 +0,0 @@ - SUBROUTINE CSYMM3MF( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX ALPHA, BETA -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* CSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the symmetric matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the symmetric matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* symmetric matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* symmetric matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP1, TEMP2 -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of CSYMM . -* - END diff --git a/reference/csymmf.f b/reference/csymmf.f deleted file mode 100644 index d5480e473..000000000 --- a/reference/csymmf.f +++ /dev/null @@ -1,296 +0,0 @@ - SUBROUTINE CSYMMF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX ALPHA, BETA -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* CSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the symmetric matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the symmetric matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* symmetric matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* symmetric matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP1, TEMP2 -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of CSYMM . -* - END diff --git a/reference/csymvf.f b/reference/csymvf.f deleted file mode 100644 index 09d247a13..000000000 --- a/reference/csymvf.f +++ /dev/null @@ -1,264 +0,0 @@ - SUBROUTINE CSYMVF(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, INCY, LDA, N - COMPLEX ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CSYMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix. -* -* Arguments -* ========== -* -* UPLO (input) CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N (input) INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA (input) COMPLEX -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A (input) COMPLEX array, dimension ( LDA, N ) -* Before entry, with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry, with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. -* Unchanged on exit. -* -* LDA (input) INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, N ). -* Unchanged on exit. -* -* X (input) COMPLEX array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the N- -* element vector x. -* Unchanged on exit. -* -* INCX (input) INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA (input) COMPLEX -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y (input/output) COMPLEX array, dimension at least -* ( 1 + ( N - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY (input) INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY - COMPLEX TEMP1, TEMP2 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = 5 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 7 - ELSE IF( INCY.EQ.0 ) THEN - INFO = 10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CSYMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 ) THEN - KX = 1 - ELSE - KX = 1 - ( N-1 )*INCX - END IF - IF( INCY.GT.0 ) THEN - KY = 1 - ELSE - KY = 1 - ( N-1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE ) THEN - IF( INCY.EQ.1 ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 10 I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO ) THEN - DO 30 I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 60 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50 I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 100 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( J, J ) - DO 90 I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) - IX = JX - IY = JY - DO 110 I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of CSYMV -* - END diff --git a/reference/csyr2f.f b/reference/csyr2f.f deleted file mode 100644 index 1fde4c0b1..000000000 --- a/reference/csyr2f.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE CSYR2F ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*8 ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*8 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SSYR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*8 ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - COMPLEX*8 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSYR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSYR2 . -* - END diff --git a/reference/csyr2kf.f b/reference/csyr2kf.f deleted file mode 100644 index f9468dd14..000000000 --- a/reference/csyr2kf.f +++ /dev/null @@ -1,324 +0,0 @@ - SUBROUTINE CSYR2KF( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - COMPLEX ALPHA, BETA -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* CSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -* beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'T' or 't', K specifies the number of rows of the -* matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX TEMP1, TEMP2 -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of CSYR2K. -* - END diff --git a/reference/csyrf.f b/reference/csyrf.f deleted file mode 100644 index f1a2d597d..000000000 --- a/reference/csyrf.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE CSYRF( UPLO, N, ALPHA, X, INCX, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, LDA, N - COMPLEX ALPHA -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CSYR performs the symmetric rank 1 operation -* -* A := alpha*x*( x' ) + A, -* -* where alpha is a complex scalar, x is an n element vector and A is an -* n by n symmetric matrix. -* -* Arguments -* ========== -* -* UPLO (input) CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N (input) INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA (input) COMPLEX -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X (input) COMPLEX array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the N- -* element vector x. -* Unchanged on exit. -* -* INCX (input) INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A (input/output) COMPLEX array, dimension ( LDA, N ) -* Before entry, with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry, with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA (input) INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, N ). -* Unchanged on exit. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, J, JX, KX - COMPLEX TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = 7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CSYR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 ) THEN - KX = 1 - ( N-1 )*INCX - ELSE IF( INCX.NE.1 ) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 ) THEN - DO 20 J = 1, N - IF( X( J ).NE.ZERO ) THEN - TEMP = ALPHA*X( J ) - DO 10 I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1, N - IF( X( JX ).NE.ZERO ) THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30 I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 ) THEN - DO 60 J = 1, N - IF( X( J ).NE.ZERO ) THEN - TEMP = ALPHA*X( J ) - DO 50 I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1, N - IF( X( JX ).NE.ZERO ) THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70 I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of CSYR -* - END diff --git a/reference/csyrkf.f b/reference/csyrkf.f deleted file mode 100644 index 7dbaefa49..000000000 --- a/reference/csyrkf.f +++ /dev/null @@ -1,293 +0,0 @@ - SUBROUTINE CSYRKF ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - COMPLEX ALPHA, BETA -* .. Array Arguments .. - COMPLEX A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* CSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't', K specifies the number of rows of the -* matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX TEMP -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of CSYRK . -* - END diff --git a/reference/ctbmvf.f b/reference/ctbmvf.f deleted file mode 100644 index ff3c5268d..000000000 --- a/reference/ctbmvf.f +++ /dev/null @@ -1,377 +0,0 @@ - SUBROUTINE CTBMVF( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CTBMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular band matrix, with ( k + 1 ) diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := conjg( A' )*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CTBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = KPLUS1 - J - DO 10, I = MAX( 1, J - K ), J - 1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( KPLUS1, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 30, I = MAX( 1, J - K ), J - 1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( KPLUS1, J ) - END IF - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = 1 - J - DO 50, I = MIN( N, J + K ), J + 1, -1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( 1, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 70, I = MIN( N, J + K ), J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( 1, J ) - END IF - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - L = KPLUS1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 90, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( I ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( KPLUS1, J ) ) - DO 100, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + CONJG( A( L + I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - KX = KX - INCX - IX = KX - L = KPLUS1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 120, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX - INCX - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( KPLUS1, J ) ) - DO 130, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + CONJG( A( L + I, J ) )*X( IX ) - IX = IX - INCX - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - L = 1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 150, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( 1, J ) ) - DO 160, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + CONJG( A( L + I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - KX = KX + INCX - IX = KX - L = 1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 180, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX + INCX - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( 1, J ) ) - DO 190, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + CONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of CTBMV . -* - END diff --git a/reference/ctbsvf.f b/reference/ctbsvf.f deleted file mode 100644 index 935843320..000000000 --- a/reference/ctbsvf.f +++ /dev/null @@ -1,367 +0,0 @@ - SUBROUTINE CTBSVF(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* .. Scalar Arguments .. - INTEGER INCX,K,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - COMPLEX A(LDA,*),X(*) -* .. -* -* Purpose -* ======= -* -* CTBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Arguments -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER (ZERO= (0.0E+0,0.0E+0)) -* .. -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC CONJG,MAX,MIN -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT. (K+1)) THEN - INFO = 7 - ELSE IF (INCX.EQ.0) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('CTBSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - L = KPLUS1 - J - IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) - TEMP = X(J) - DO 10 I = J - 1,MAX(1,J-K),-1 - X(I) = X(I) - TEMP*A(L+I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 40 J = N,1,-1 - KX = KX - INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = KPLUS1 - J - IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) - TEMP = X(JX) - DO 30 I = J - 1,MAX(1,J-K),-1 - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - L = 1 - J - IF (NOUNIT) X(J) = X(J)/A(1,J) - TEMP = X(J) - DO 50 I = J + 1,MIN(N,J+K) - X(I) = X(I) - TEMP*A(L+I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - KX = KX + INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = 1 - J - IF (NOUNIT) X(JX) = X(JX)/A(1,J) - TEMP = X(JX) - DO 70 I = J + 1,MIN(N,J+K) - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A') )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = X(J) - L = KPLUS1 - J - IF (NOCONJ) THEN - DO 90 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - ELSE - DO 100 I = MAX(1,J-K),J - 1 - TEMP = TEMP - CONJG(A(L+I,J))*X(I) - 100 CONTINUE - IF (NOUNIT) TEMP = TEMP/CONJG(A(KPLUS1,J)) - END IF - X(J) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140 J = 1,N - TEMP = X(JX) - IX = KX - L = KPLUS1 - J - IF (NOCONJ) THEN - DO 120 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX + INCX - 120 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - ELSE - DO 130 I = MAX(1,J-K),J - 1 - TEMP = TEMP - CONJG(A(L+I,J))*X(IX) - IX = IX + INCX - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/CONJG(A(KPLUS1,J)) - END IF - X(JX) = TEMP - JX = JX + INCX - IF (J.GT.K) KX = KX + INCX - 140 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 170 J = N,1,-1 - TEMP = X(J) - L = 1 - J - IF (NOCONJ) THEN - DO 150 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(I) - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - ELSE - DO 160 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - CONJG(A(L+I,J))*X(I) - 160 CONTINUE - IF (NOUNIT) TEMP = TEMP/CONJG(A(1,J)) - END IF - X(J) = TEMP - 170 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 200 J = N,1,-1 - TEMP = X(JX) - IX = KX - L = 1 - J - IF (NOCONJ) THEN - DO 180 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX - INCX - 180 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - ELSE - DO 190 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - CONJG(A(L+I,J))*X(IX) - IX = IX - INCX - 190 CONTINUE - IF (NOUNIT) TEMP = TEMP/CONJG(A(1,J)) - END IF - X(JX) = TEMP - JX = JX - INCX - IF ((N-J).GE.K) KX = KX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of CTBSV . -* - END diff --git a/reference/ctpmvf.f b/reference/ctpmvf.f deleted file mode 100644 index 340234270..000000000 --- a/reference/ctpmvf.f +++ /dev/null @@ -1,376 +0,0 @@ - SUBROUTINE CTPMVF( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CTPMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := conjg( A' )*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - COMPLEX array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CTPMVF', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ).OR.LSAME( TRANS, 'R' ))THEN -* -* Form x:= A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 10, I = 1, J - 1 - IF( NOCONJ )THEN - X( I ) = X( I ) + TEMP*AP( K ) - ELSE - X( I ) = X( I ) + TEMP*CONJG(AP( K )) - END IF - K = K + 1 - 10 CONTINUE - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK + J - 1 ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )*CONJG(AP( KK + J-1)) - END IF - END IF - - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, K = KK, KK + J - 2 - IF( NOCONJ )THEN - X( IX ) = X( IX ) + TEMP*AP( K ) - ELSE - X( IX ) = X( IX ) + TEMP*CONJG(AP(K)) - END IF - IX = IX + INCX - 30 CONTINUE - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK + J - 1 ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )*CONJG(AP( KK + J-1)) - END IF - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 50, I = N, J + 1, -1 - IF( NOCONJ )THEN - X( I ) = X( I ) + TEMP*AP( K ) - ELSE - X( I ) = X( I ) + TEMP*CONJG(AP( K )) - END IF - K = K - 1 - 50 CONTINUE - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK - N + J ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )*CONJG(AP(KK - N+J)) - END IF - END IF - KK = KK - ( N - J + 1 ) - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 - IF( NOCONJ )THEN - X( IX ) = X( IX ) + TEMP*AP( K ) - ELSE - X( IX ) = X( IX ) + TEMP*CONJG(AP(K)) - ENDIF - IX = IX - INCX - 70 CONTINUE - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK - N + J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )*CONJG(AP(KK-N+J)) - ENDIF - END IF - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - K = KK - 1 - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + AP( K )*X( I ) - K = K - 1 - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( AP( KK ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + CONJG( AP( K ) )*X( I ) - K = K - 1 - 100 CONTINUE - END IF - X( J ) = TEMP - KK = KK - J - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 120, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + AP( K )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( AP( KK ) ) - DO 130, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + CONJG( AP( K ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - KK = KK - J - 140 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - K = KK + 1 - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 150, I = J + 1, N - TEMP = TEMP + AP( K )*X( I ) - K = K + 1 - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( AP( KK ) ) - DO 160, I = J + 1, N - TEMP = TEMP + CONJG( AP( K ) )*X( I ) - K = K + 1 - 160 CONTINUE - END IF - X( J ) = TEMP - KK = KK + ( N - J + 1 ) - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 180, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + AP( K )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( AP( KK ) ) - DO 190, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + CONJG( AP( K ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of CTPMV . -* - END diff --git a/reference/ctpsvf.f b/reference/ctpsvf.f deleted file mode 100644 index 2da921512..000000000 --- a/reference/ctpsvf.f +++ /dev/null @@ -1,379 +0,0 @@ - SUBROUTINE CTPSVF( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CTPSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix, supplied in packed form. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - COMPLEX array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CTPSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) .OR.LSAME( TRANS, 'R' ))THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )/CONJG(AP( KK )) - END IF - - TEMP = X( J ) - K = KK - 1 - DO 10, I = J - 1, 1, -1 - IF( NOCONJ )THEN - X( I ) = X( I ) - TEMP*AP( K ) - ELSE - X( I ) = X( I ) - TEMP*CONJG(AP( K )) - END IF - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )/CONJG(AP( KK )) - END IF - TEMP = X( JX ) - IX = JX - DO 30, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - IF( NOCONJ )THEN - X( IX ) = X( IX ) - TEMP*AP( K ) - ELSE - X( IX ) = X( IX ) - TEMP*CONJG(AP( K )) - END IF - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )/CONJG(AP( KK )) - END IF - TEMP = X( J ) - K = KK + 1 - DO 50, I = J + 1, N - IF( NOCONJ )THEN - X( I ) = X( I ) - TEMP*AP( K ) - ELSE - X( I ) = X( I ) - TEMP*CONJG(AP( K )) - END IF - K = K + 1 - 50 CONTINUE - END IF - KK = KK + ( N - J + 1 ) - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )/CONJG(AP( KK )) - END IF - TEMP = X( JX ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - IF( NOCONJ )THEN - X( IX ) = X( IX ) - TEMP*AP( K ) - ELSE - X( IX ) = X( IX ) - TEMP*CONJG(AP( K )) - END IF - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - K = KK - IF( NOCONJ )THEN - DO 90, I = 1, J - 1 - TEMP = TEMP - AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - CONJG( AP( K ) )*X( I ) - K = K + 1 - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( AP( KK + J - 1 ) ) - END IF - X( J ) = TEMP - KK = KK + J - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - TEMP = X( JX ) - IX = KX - IF( NOCONJ )THEN - DO 120, K = KK, KK + J - 2 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - ELSE - DO 130, K = KK, KK + J - 2 - TEMP = TEMP - CONJG( AP( K ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( AP( KK + J - 1 ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - KK = KK + J - 140 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - K = KK - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - AP( K )*X( I ) - K = K - 1 - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - CONJG( AP( K ) )*X( I ) - K = K - 1 - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( AP( KK - N + J ) ) - END IF - X( J ) = TEMP - KK = KK - ( N - J + 1 ) - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - IF( NOCONJ )THEN - DO 180, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - ELSE - DO 190, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - CONJG( AP( K ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( AP( KK - N + J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of CTPSV . -* - END diff --git a/reference/ctrmmf.f b/reference/ctrmmf.f deleted file mode 100644 index d65bf4484..000000000 --- a/reference/ctrmmf.f +++ /dev/null @@ -1,428 +0,0 @@ - SUBROUTINE CTRMMF ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX ALPHA -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* CTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ) -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'R' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'R' ))THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - IF (NOCONJ) THEN - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - ELSE - DO 35, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*CONJG(A( I, K )) - 35 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG(A( K, K )) - B( K, J ) = TEMP - ENDIF - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF (NOCONJ) THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - ELSE - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*CONJG(A( K, K )) - DO 65, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*CONJG(A( I, K )) - 65 CONTINUE - ENDIF - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. -* - IF( UPPER )THEN - DO 120, J = 1, N - DO 110, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( I, I ) ) - DO 100, K = 1, I - 1 - TEMP = TEMP + CONJG( A( K, I ) )*B( K, J ) - 100 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 110 CONTINUE - 120 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = 1, M - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 130, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 130 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( I, I ) ) - DO 140, K = I + 1, M - TEMP = TEMP + CONJG( A( K, I ) )*B( K, J ) - 140 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'R' ))THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 200, J = N, 1, -1 - TEMP = ALPHA - IF (NOCONJ) THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG(A( J, J )) - ENDIF - DO 170, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 170 CONTINUE - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - IF (NOCONJ) THEN - TEMP = ALPHA*A( K, J ) - ELSE - TEMP = ALPHA*CONJG(A( K, J )) - ENDIF - DO 180, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE - DO 240, J = 1, N - TEMP = ALPHA - IF (NOCONJ) THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG(A( J, J )) - ENDIF - DO 210, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 210 CONTINUE - DO 230, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - IF (NOCONJ) THEN - TEMP = ALPHA*A( K, J ) - ELSE - TEMP = ALPHA*CONJG(A( K, J )) - ENDIF - DO 220, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 220 CONTINUE - END IF - 230 CONTINUE - 240 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). -* - IF( UPPER )THEN - DO 280, K = 1, N - DO 260, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*CONJG( A( J, K ) ) - END IF - DO 250, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*CONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - ELSE - DO 320, K = N, 1, -1 - DO 300, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*CONJG( A( J, K ) ) - END IF - DO 290, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*CONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 310, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 310 CONTINUE - END IF - 320 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of CTRMM . -* - END diff --git a/reference/ctrmvf.f b/reference/ctrmvf.f deleted file mode 100644 index f9d3b445a..000000000 --- a/reference/ctrmvf.f +++ /dev/null @@ -1,358 +0,0 @@ - SUBROUTINE CTRMVF ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := conjg( A' )*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'R' ))THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - IF (NOCONJ) THEN - X( I ) = X( I ) + TEMP*A( I, J ) - ELSE - X( I ) = X( I ) + TEMP*CONJG(A( I, J )) - ENDIF - 10 CONTINUE - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )*CONJG(A( J, J )) - ENDIF - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - IF (NOCONJ) THEN - X( IX ) = X( IX ) + TEMP*A( I, J ) - ELSE - X( IX ) = X( IX ) + TEMP*CONJG(A( I, J )) - ENDIF - IX = IX + INCX - 30 CONTINUE - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )*CONJG(A( J, J )) - ENDIF - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - IF (NOCONJ) THEN - X( I ) = X( I ) + TEMP*A( I, J ) - ELSE - X( I ) = X( I ) + TEMP*CONJG(A( I, J )) - ENDIF - 50 CONTINUE - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )*CONJG(A( J, J )) - ENDIF - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - IF (NOCONJ) THEN - X( IX ) = X( IX ) + TEMP*A( I, J ) - ELSE - X( IX ) = X( IX ) + TEMP*CONJG(A( I, J )) - ENDIF - IX = IX - INCX - 70 CONTINUE - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )*CONJG(A( J, J )) - ENDIF - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( J, J ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + CONJG( A( I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 120, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( J, J ) ) - DO 130, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( J, J ) ) - DO 160, I = J + 1, N - TEMP = TEMP + CONJG( A( I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 180, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*CONJG( A( J, J ) ) - DO 190, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of CTRMV . -* - END diff --git a/reference/ctrsmf.f b/reference/ctrsmf.f deleted file mode 100644 index 3d27822d1..000000000 --- a/reference/ctrsmf.f +++ /dev/null @@ -1,459 +0,0 @@ - SUBROUTINE CTRSMF ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX ALPHA -* .. Array Arguments .. - COMPLEX A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* CTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX TEMP -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = (LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'T' )) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'R' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'R' ))THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - - IF( NOUNIT ) THEN - IF (NOCONJ) THEN - B( K, J ) = B( K, J )/A( K, K ) - ELSE - B( K, J ) = B( K, J )/CONJG(A( K, K )) - ENDIF - ENDIF - - IF (NOCONJ) THEN - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - ELSE - DO 45, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*CONJG(A( I, K )) - 45 CONTINUE - ENDIF - ENDIF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF (NOCONJ) THEN - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - ELSE - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/CONJG(A( K, K )) - DO 85, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*CONJG(A( I, K )) - 85 CONTINUE - END IF - ENDIF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B -* or B := alpha*inv( conjg( A' ) )*B. -* - IF( UPPER )THEN - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 120, K = 1, I - 1 - TEMP = TEMP - CONJG( A( K, I ) )*B( K, J ) - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 130 CONTINUE - 140 CONTINUE - ELSE - DO 180, J = 1, N - DO 170, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 150, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 160, K = I + 1, M - TEMP = TEMP - CONJG( A( K, I ) )*B( K, J ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 170 CONTINUE - 180 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'R' ))THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 230, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 190, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 190 CONTINUE - END IF - DO 210, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - IF (NOCONJ) THEN - DO 200, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 200 CONTINUE - ELSE - DO 205, I = 1, M - B( I, J ) = B( I, J ) - CONJG(A( K, J ))*B( I, K ) - 205 CONTINUE - ENDIF - END IF - 210 CONTINUE - IF( NOUNIT )THEN - IF (NOCONJ) THEN - TEMP = ONE/A( J, J ) - ELSE - TEMP = ONE/CONJG(A( J, J )) - ENDIF - DO 220, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 220 CONTINUE - END IF - 230 CONTINUE - ELSE - DO 280, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 240, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 240 CONTINUE - END IF - DO 260, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - IF (NOCONJ) THEN - DO 250, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 250 CONTINUE - ELSE - DO 255, I = 1, M - B( I, J ) = B( I, J ) - CONJG(A( K, J ))*B( I, K ) - 255 CONTINUE - ENDIF - END IF - 260 CONTINUE - IF( NOUNIT )THEN - IF (NOCONJ) THEN - TEMP = ONE/A( J, J ) - ELSE - TEMP = ONE/CONJG(A( J, J )) - ENDIF - DO 270, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 270 CONTINUE - END IF - 280 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ) -* or B := alpha*B*inv( conjg( A' ) ). -* - IF( UPPER )THEN - DO 330, K = N, 1, -1 - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/CONJG( A( K, K ) ) - END IF - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - DO 310, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = CONJG( A( J, K ) ) - END IF - DO 300, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 320, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 320 CONTINUE - END IF - 330 CONTINUE - ELSE - DO 380, K = 1, N - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/CONJG( A( K, K ) ) - END IF - DO 340, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 340 CONTINUE - END IF - DO 360, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = CONJG( A( J, K ) ) - END IF - DO 350, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 370, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 370 CONTINUE - END IF - 380 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of CTRSM . -* - END diff --git a/reference/ctrsvf.f b/reference/ctrsvf.f deleted file mode 100644 index 86061b48b..000000000 --- a/reference/ctrsvf.f +++ /dev/null @@ -1,361 +0,0 @@ - SUBROUTINE CTRSVF ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* CTRSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - COMPLEX TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC CONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CTRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'R' ))THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )/CONJG(A( J, J )) - TEMP = X( J ) - DO 15, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*CONJG(A( I, J )) - 15 CONTINUE - ENDIF - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )/CONJG(A( J, J )) - ENDIF - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - IF (NOCONJ) THEN - X( IX ) = X( IX ) - TEMP*A( I, J ) - ELSE - X( IX ) = X( IX ) - TEMP*CONJG(A( I, J )) - ENDIF - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )/CONJG(A( J, J )) - TEMP = X( J ) - DO 55, I = J + 1, N - X( I ) = X( I ) - TEMP*CONJG(A( I, J )) - 55 CONTINUE - ENDIF - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )/CONJG(A( J, J )) - ENDIF - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - IF (NOCONJ) THEN - X( IX ) = X( IX ) - TEMP*A( I, J ) - ELSE - X( IX ) = X( IX ) - TEMP*CONJG(A( I, J )) - ENDIF - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - CONJG( A( I, J ) )*X( I ) - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 120, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 130, I = 1, J - 1 - TEMP = TEMP - CONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - CONJG( A( I, J ) )*X( I ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 180, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 190, I = N, J + 1, -1 - TEMP = TEMP - CONJG( A( I, J ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/CONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of CTRSV . -* - END diff --git a/reference/ctrti2f.f b/reference/ctrti2f.f deleted file mode 100644 index 24604b4b5..000000000 --- a/reference/ctrti2f.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE CTRTI2F( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CTRTI2 computes the inverse of a complex upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - COMPLEX AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL CSCAL, CTRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL CTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL CSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL CTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL CSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of CTRTI2 -* - END diff --git a/reference/ctrtrif.f b/reference/ctrtrif.f deleted file mode 100644 index cb1ec980a..000000000 --- a/reference/ctrtrif.f +++ /dev/null @@ -1,177 +0,0 @@ - SUBROUTINE CTRTRIF( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* CTRTRI computes the inverse of a complex upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX ONE, ZERO - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), - $ ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL CTRMM, CTRSM, CTRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'CTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = 128 - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL CTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL CTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL CTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL CTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL CTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL CTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL CTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of CTRTRI -* - END diff --git a/reference/damaxf.f b/reference/damaxf.f deleted file mode 100644 index a0c0b0191..000000000 --- a/reference/damaxf.f +++ /dev/null @@ -1,36 +0,0 @@ - REAL*8 function damaxf(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*) - integer i,incx,ix,n -c - damaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - damaxf = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.damaxf) go to 5 - damaxf = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 damaxf = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.damaxf) go to 30 - damaxf = dabs(dx(i)) - 30 continue - return - end diff --git a/reference/daminf.f b/reference/daminf.f deleted file mode 100644 index 21ce9d7c0..000000000 --- a/reference/daminf.f +++ /dev/null @@ -1,36 +0,0 @@ - REAL*8 function daminf(n,dx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*) - integer i,incx,ix,n -c - daminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - daminf = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).ge.daminf) go to 5 - daminf = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 daminf = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).ge.daminf) go to 30 - daminf = dabs(dx(i)) - 30 continue - return - end diff --git a/reference/dasumf.f b/reference/dasumf.f deleted file mode 100644 index 0713694dd..000000000 --- a/reference/dasumf.f +++ /dev/null @@ -1,43 +0,0 @@ - double precision function dasumf(n,dx,incx) -c -c takes the sum of the absolute values. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dtemp - integer i,incx,m,mp1,n,nincx -c - dasumf = 0.0d0 - dtemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dtemp = dtemp + dabs(dx(i)) - 10 continue - dasumf = dtemp - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,6) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dabs(dx(i)) - 30 continue - if( n .lt. 6 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,6 - dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) - * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) - 50 continue - 60 dasumf = dtemp - return - end diff --git a/reference/daxpyf.f b/reference/daxpyf.f deleted file mode 100644 index 259217c21..000000000 --- a/reference/daxpyf.f +++ /dev/null @@ -1,48 +0,0 @@ - subroutine daxpyf(n,da,dx,incx,dy,incy) -c -c constant times a vector plus a vector. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),da - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if (da .eq. 0.0d0) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dy(iy) + da*dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,4) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dy(i) + da*dx(i) - 30 continue - if( n .lt. 4 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,4 - dy(i) = dy(i) + da*dx(i) - dy(i + 1) = dy(i + 1) + da*dx(i + 1) - dy(i + 2) = dy(i + 2) + da*dx(i + 2) - dy(i + 3) = dy(i + 3) + da*dx(i + 3) - 50 continue - return - end diff --git a/reference/dcopyf.f b/reference/dcopyf.f deleted file mode 100644 index e9303034f..000000000 --- a/reference/dcopyf.f +++ /dev/null @@ -1,50 +0,0 @@ - subroutine dcopyf(n,dx,incx,dy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - 50 continue - return - end diff --git a/reference/ddotf.f b/reference/ddotf.f deleted file mode 100644 index ed8defcb8..000000000 --- a/reference/ddotf.f +++ /dev/null @@ -1,49 +0,0 @@ - double precision function ddotf(n,dx,incx,dy,incy) -c -c forms the dot product of two vectors. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - ddotf = 0.0d0 - dtemp = 0.0d0 - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dtemp + dx(ix)*dy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - ddotf = dtemp - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dx(i)*dy(i) - 30 continue - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + - * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) - 50 continue - 60 ddotf = dtemp - return - end diff --git a/reference/dgbmvf.f b/reference/dgbmvf.f deleted file mode 100644 index 0033ac190..000000000 --- a/reference/dgbmvf.f +++ /dev/null @@ -1,300 +0,0 @@ - SUBROUTINE DGBMVF( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGBMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n band matrix, with kl sub-diagonals and ku super-diagonals. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* KL - INTEGER. -* On entry, KL specifies the number of sub-diagonals of the -* matrix A. KL must satisfy 0 .le. KL. -* Unchanged on exit. -* -* KU - INTEGER. -* On entry, KU specifies the number of super-diagonals of the -* matrix A. KU must satisfy 0 .le. KU. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry, the leading ( kl + ku + 1 ) by n part of the -* array A must contain the matrix of coefficients, supplied -* column by column, with the leading diagonal of the matrix in -* row ( ku + 1 ) of the array, the first super-diagonal -* starting at position 2 in row ku, the first sub-diagonal -* starting at position 1 in row ( ku + 2 ), and so on. -* Elements in the array A that do not correspond to elements -* in the band matrix (such as the top left ku by ku triangle) -* are not referenced. -* The following program segment will transfer a band matrix -* from conventional full matrix storage to band storage: -* -* DO 20, J = 1, N -* K = KU + 1 - J -* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -* A( K + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( kl + ku + 1 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( KL.LT.0 )THEN - INFO = 4 - ELSE IF( KU.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN - INFO = 8 - ELSE IF( INCX.EQ.0 )THEN - INFO = 10 - ELSE IF( INCY.EQ.0 )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the band part of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KUP1 = KU + 1 - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - K = KUP1 - J - DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - K = KUP1 - J - DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - K = KUP1 - J - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGBMV . -* - END diff --git a/reference/dgemmf.f b/reference/dgemmf.f deleted file mode 100644 index 0af812014..000000000 --- a/reference/dgemmf.f +++ /dev/null @@ -1,313 +0,0 @@ - SUBROUTINE DGEMMF(TRANA,TRANB,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 TRANA,TRANB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* Purpose -* ======= -* -* 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', -* -* 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. -* -* Arguments -* ========== -* -* TRANA - CHARACTER*1. -* On entry, TRANA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANA = 'N' or 'n', op( A ) = A. -* -* TRANA = 'T' or 't', op( A ) = A'. -* -* TRANA = 'C' or 'c', op( A ) = A'. -* -* Unchanged on exit. -* -* TRANB - CHARACTER*1. -* On entry, TRANB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANB = 'N' or 'n', op( B ) = B. -* -* TRANB = 'T' or 't', op( B ) = B'. -* -* TRANB = 'C' or 'c', op( B ) = B'. -* -* Unchanged on exit. -* -* M - 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. -* Unchanged on exit. -* -* N - 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. -* Unchanged on exit. -* -* K - 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. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANA = 'N' or 'n', and is m otherwise. -* Before entry with TRANA = '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. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -* n when TRANB = 'N' or 'n', and is k otherwise. -* Before entry with TRANB = '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. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of 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 ). -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. 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(TRANA,'N') - NOTB = LSAME(TRANB,'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(TRANA,'C')) .AND. - + (.NOT.LSAME(TRANA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANB,'C')) .AND. - + (.NOT.LSAME(TRANB,'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 - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*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' + 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 - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + 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 diff --git a/reference/dgemvf.f b/reference/dgemvf.f deleted file mode 100644 index ae50c3ce2..000000000 --- a/reference/dgemvf.f +++ /dev/null @@ -1,256 +0,0 @@ - SUBROUTINE DGEMVF ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - DO 110, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END diff --git a/reference/dgerf.f b/reference/dgerf.f deleted file mode 100644 index f340ceb56..000000000 --- a/reference/dgerf.f +++ /dev/null @@ -1,158 +0,0 @@ - SUBROUTINE DGERF ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) - -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGER performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END diff --git a/reference/dgesvf.f b/reference/dgesvf.f deleted file mode 100644 index 751acf349..000000000 --- a/reference/dgesvf.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE DGESVF( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGESV computes the solution to a real system of linear equations -* A * X = B, -* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as -* A = P * L * U, -* where P is a permutation matrix, L is unit lower triangular, and U is -* upper triangular. The factored form of A is then used to solve the -* system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the N-by-N coefficient matrix A. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS matrix of right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, so the solution could not be computed. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DGETRF, DGETRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL DGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of DGESV -* - END diff --git a/reference/dgetf2f.f b/reference/dgetf2f.f deleted file mode 100644 index f977a7c11..000000000 --- a/reference/dgetf2f.f +++ /dev/null @@ -1,135 +0,0 @@ - SUBROUTINE DGETF2F( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END diff --git a/reference/dgetrff.f b/reference/dgetrff.f deleted file mode 100644 index 1425596c8..000000000 --- a/reference/dgetrff.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE DGETRFF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 64 - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END diff --git a/reference/dgetrsf.f b/reference/dgetrsf.f deleted file mode 100644 index 86624cb71..000000000 --- a/reference/dgetrsf.f +++ /dev/null @@ -1,150 +0,0 @@ - SUBROUTINE DGETRSF( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A' * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END diff --git a/reference/dlaswpf.f b/reference/dlaswpf.f deleted file mode 100644 index 1e83dbe73..000000000 --- a/reference/dlaswpf.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE DLASWPF( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END diff --git a/reference/dlauu2f.f b/reference/dlauu2f.f deleted file mode 100644 index 0f957b426..000000000 --- a/reference/dlauu2f.f +++ /dev/null @@ -1,135 +0,0 @@ - SUBROUTINE DLAUU2F( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLAUU2 computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the unblocked form of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAUU2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 ) - ELSE - CALL DSCAL( I, AII, A( 1, I ), 1 ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, AII, A( I, 1 ), LDA ) - ELSE - CALL DSCAL( I, AII, A( I, 1 ), LDA ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DLAUU2 -* - END diff --git a/reference/dlauumf.f b/reference/dlauumf.f deleted file mode 100644 index c0584cc0d..000000000 --- a/reference/dlauumf.f +++ /dev/null @@ -1,155 +0,0 @@ - SUBROUTINE DLAUUMF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLAUUM computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the blocked form of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DLAUU2, DSYRK, DTRMM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLAUUM', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 128 -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), - $ LDA ) - CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL DGEMM( 'No transpose', 'Transpose', I-1, IB, - $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, - $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) - CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB, - $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) - CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL DGEMM( 'Transpose', 'No transpose', IB, I-1, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) - CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE, - $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF -* - RETURN -* -* End of DLAUUM -* - END diff --git a/reference/dmaxf.f b/reference/dmaxf.f deleted file mode 100644 index 11a7322fa..000000000 --- a/reference/dmaxf.f +++ /dev/null @@ -1,36 +0,0 @@ - REAL*8 function dmaxf(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*) - integer i,incx,ix,n -c - dmaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmaxf = dx(1) - ix = ix + incx - do 10 i = 2,n - if(dx(ix).le.dmaxf) go to 5 - dmaxf = dx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmaxf = dx(1) - do 30 i = 2,n - if(dx(i).le.dmaxf) go to 30 - dmaxf = dx(i) - 30 continue - return - end diff --git a/reference/dminf.f b/reference/dminf.f deleted file mode 100644 index 497fb533d..000000000 --- a/reference/dminf.f +++ /dev/null @@ -1,36 +0,0 @@ - REAL*8 function dminf(n,dx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*) - integer i,incx,ix,n -c - dminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dminf = dx(1) - ix = ix + incx - do 10 i = 2,n - if(dx(ix).ge.dminf) go to 5 - dminf = dx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dminf = dx(1) - do 30 i = 2,n - if(dx(i).ge.dminf) go to 30 - dminf = dx(i) - 30 continue - return - end diff --git a/reference/dnrm2f.f b/reference/dnrm2f.f deleted file mode 100644 index 2a4b6f2e9..000000000 --- a/reference/dnrm2f.f +++ /dev/null @@ -1,61 +0,0 @@ - DOUBLE PRECISION FUNCTION DNRM2F ( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. - - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE IF( N.EQ.1 )THEN - NORM = ABS( X( 1 ) ) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SSQ = ONE + SSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DNRM2F = NORM - RETURN -* -* End of DNRM2. -* - END diff --git a/reference/dpotf2f.f b/reference/dpotf2f.f deleted file mode 100644 index 932726361..000000000 --- a/reference/dpotf2f.f +++ /dev/null @@ -1,168 +0,0 @@ - SUBROUTINE DPOTF2F( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTF2 computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) - CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), - $ LDA ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) - CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of DPOTF2 -* - END diff --git a/reference/dpotrff.f b/reference/dpotrff.f deleted file mode 100644 index 10faf0557..000000000 --- a/reference/dpotrff.f +++ /dev/null @@ -1,184 +0,0 @@ - SUBROUTINE DPOTRFF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRF computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U**T * U, if UPLO = 'U', or -* A = L * L**T, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 224 - - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL DPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, - $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), - $ LDA, ONE, A( J, J+JB ), LDA ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, - $ A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), - $ LDA, ONE, A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-J-JB+1, JB, ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of DPOTRF -* - END diff --git a/reference/dpotrif.f b/reference/dpotrif.f deleted file mode 100644 index 202704243..000000000 --- a/reference/dpotrif.f +++ /dev/null @@ -1,96 +0,0 @@ - SUBROUTINE DPOTRIF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRI computes the inverse of a real symmetric positive definite -* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T -* computed by DPOTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T, as computed by -* DPOTRF. -* On exit, the upper or lower triangle of the (symmetric) -* inverse of A, overwriting the input factor U or L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the (i,i) element of the factor U or L is -* zero, and the inverse could not be computed. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLAUUM, DTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Invert the triangular Cholesky factor U or L. -* - CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* -* Form inv(U)*inv(U)' or inv(L)'*inv(L). -* - CALL DLAUUM( UPLO, N, A, LDA, INFO ) -* - RETURN -* -* End of DPOTRI -* - END diff --git a/reference/drotf.f b/reference/drotf.f deleted file mode 100644 index 70525ad7d..000000000 --- a/reference/drotf.f +++ /dev/null @@ -1,37 +0,0 @@ - subroutine drotf (n,dx,incx,dy,incy,c,s) -c -c applies a plane rotation. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp,c,s - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = c*dx(ix) + s*dy(iy) - dy(iy) = c*dy(iy) - s*dx(ix) - dx(ix) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - dtemp = c*dx(i) + s*dy(i) - dy(i) = c*dy(i) - s*dx(i) - dx(i) = dtemp - 30 continue - return - end diff --git a/reference/drotgf.f b/reference/drotgf.f deleted file mode 100644 index 265a7cd73..000000000 --- a/reference/drotgf.f +++ /dev/null @@ -1,27 +0,0 @@ - subroutine drotgf(da,db,c,s) -c -c construct givens plane rotation. -c jack dongarra, linpack, 3/11/78. -c - double precision da,db,c,s,roe,scale,r,z -c - roe = db - if( dabs(da) .gt. dabs(db) ) roe = da - scale = dabs(da) + dabs(db) - if( scale .ne. 0.0d0 ) go to 10 - c = 1.0d0 - s = 0.0d0 - r = 0.0d0 - z = 0.0d0 - go to 20 - 10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2) - r = dsign(1.0d0,roe)*r - c = da/r - s = db/r - z = 1.0d0 - if( dabs(da) .gt. dabs(db) ) z = s - if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c - 20 da = r - db = z - return - end diff --git a/reference/drotmf.f b/reference/drotmf.f deleted file mode 100644 index 7447680e3..000000000 --- a/reference/drotmf.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE DROTMF (N,DX,INCX,DY,INCY,DPARAM) -C -C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX -C -C (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN -C (DY**T) -C -C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE -C LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. -C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. -C - DOUBLE PRECISION DFLAG,DH12,DH22,DX,TWO,Z,DH11,DH21, - 1 DPARAM,DY,W,ZERO - DIMENSION DX(1),DY(1),DPARAM(5) - DATA ZERO,TWO/0.D0,2.D0/ -C - DFLAG=DPARAM(1) - IF(N .LE. 0 .OR.(DFLAG+TWO.EQ.ZERO)) GO TO 140 - IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 -C - NSTEPS=N*INCX - IF(DFLAG) 50,10,30 - 10 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 20 I=1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W+Z*DH12 - DY(I)=W*DH21+Z - 20 CONTINUE - GO TO 140 - 30 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 40 I=1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z - DY(I)=-W+DH22*Z - 40 CONTINUE - GO TO 140 - 50 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 60 I=1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z*DH12 - DY(I)=W*DH21+Z*DH22 - 60 CONTINUE - GO TO 140 - 70 CONTINUE - KX=1 - KY=1 - IF(INCX .LT. 0) KX=1+(1-N)*INCX - IF(INCY .LT. 0) KY=1+(1-N)*INCY -C - IF(DFLAG)120,80,100 - 80 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 90 I=1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W+Z*DH12 - DY(KY)=W*DH21+Z - KX=KX+INCX - KY=KY+INCY - 90 CONTINUE - GO TO 140 - 100 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 110 I=1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z - DY(KY)=-W+DH22*Z - KX=KX+INCX - KY=KY+INCY - 110 CONTINUE - GO TO 140 - 120 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 130 I=1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z*DH12 - DY(KY)=W*DH21+Z*DH22 - KX=KX+INCX - KY=KY+INCY - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/reference/drotmgf.f b/reference/drotmgf.f deleted file mode 100644 index bc9c03eea..000000000 --- a/reference/drotmgf.f +++ /dev/null @@ -1,169 +0,0 @@ - SUBROUTINE DROTMGF (DD1,DD2,DX1,DY1,DPARAM) -C -C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS -C THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* -C DY2)**T. -C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 -C RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE -C VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) -C -C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE -C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE -C OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. -C - DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2, - 1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1, - 2 DTEMP,DX1,TWO - DIMENSION DPARAM(5) -C - DATA ZERO,ONE,TWO /0.D0,1.D0,2.D0/ - DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ - IF(.NOT. DD1 .LT. ZERO) GO TO 10 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 10 CONTINUE -C CASE-DD1-NONNEGATIVE - DP2=DD2*DY1 - IF(.NOT. DP2 .EQ. ZERO) GO TO 20 - DFLAG=-TWO - GO TO 260 -C REGULAR-CASE.. - 20 CONTINUE - DP1=DD1*DX1 - DQ2=DP2*DY1 - DQ1=DP1*DX1 -C - IF(.NOT. DABS(DQ1) .GT. DABS(DQ2)) GO TO 40 - DH21=-DY1/DX1 - DH12=DP2/DP1 -C - DU=ONE-DH12*DH21 -C - IF(.NOT. DU .LE. ZERO) GO TO 30 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 30 CONTINUE - DFLAG=ZERO - DD1=DD1/DU - DD2=DD2/DU - DX1=DX1*DU -C GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF(.NOT. DQ2 .LT. ZERO) GO TO 50 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 50 CONTINUE - DFLAG=ONE - DH11=DP1/DP2 - DH22=DX1/DY1 - DU=ONE+DH11*DH22 - DTEMP=DD2/DU - DD2=DD1/DU - DD1=DTEMP - DX1=DY1*DU -C GO SCALE-CHECK - GO TO 100 -C PROCEDURE..ZERO-H-D-AND-DX1.. - 60 CONTINUE - DFLAG=-ONE - DH11=ZERO - DH12=ZERO - DH21=ZERO - DH22=ZERO -C - DD1=ZERO - DD2=ZERO - DX1=ZERO -C RETURN.. - GO TO 220 -C PROCEDURE..FIX-H.. - 70 CONTINUE - IF(.NOT. DFLAG .GE. ZERO) GO TO 90 -C - IF(.NOT. DFLAG .EQ. ZERO) GO TO 80 - DH11=ONE - DH22=ONE - DFLAG=-ONE - GO TO 90 - 80 CONTINUE - DH21=-ONE - DH12=ONE - DFLAG=-ONE - 90 CONTINUE - GO TO IGO,(120,150,180,210) -C PROCEDURE..SCALE-CHECK - 100 CONTINUE - 110 CONTINUE - IF(.NOT. DD1 .LE. RGAMSQ) GO TO 130 - IF(DD1 .EQ. ZERO) GO TO 160 - ASSIGN 120 TO IGO -C FIX-H.. - GO TO 70 - 120 CONTINUE - DD1=DD1*GAM**2 - DX1=DX1/GAM - DH11=DH11/GAM - DH12=DH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF(.NOT. DD1 .GE. GAMSQ) GO TO 160 - ASSIGN 150 TO IGO -C FIX-H.. - GO TO 70 - 150 CONTINUE - DD1=DD1/GAM**2 - DX1=DX1*GAM - DH11=DH11*GAM - DH12=DH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF(.NOT. DABS(DD2) .LE. RGAMSQ) GO TO 190 - IF(DD2 .EQ. ZERO) GO TO 220 - ASSIGN 180 TO IGO -C FIX-H.. - GO TO 70 - 180 CONTINUE - DD2=DD2*GAM**2 - DH21=DH21/GAM - DH22=DH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF(.NOT. DABS(DD2) .GE. GAMSQ) GO TO 220 - ASSIGN 210 TO IGO -C FIX-H.. - GO TO 70 - 210 CONTINUE - DD2=DD2/GAM**2 - DH21=DH21*GAM - DH22=DH22*GAM - GO TO 200 - 220 CONTINUE - IF(DFLAG)250,230,240 - 230 CONTINUE - DPARAM(3)=DH21 - DPARAM(4)=DH12 - GO TO 260 - 240 CONTINUE - DPARAM(2)=DH11 - DPARAM(5)=DH22 - GO TO 260 - 250 CONTINUE - DPARAM(2)=DH11 - DPARAM(3)=DH21 - DPARAM(4)=DH12 - DPARAM(5)=DH22 - 260 CONTINUE - DPARAM(1)=DFLAG - RETURN - END diff --git a/reference/dsbmvf.f b/reference/dsbmvf.f deleted file mode 100644 index 7a882a3f8..000000000 --- a/reference/dsbmvf.f +++ /dev/null @@ -1,303 +0,0 @@ - SUBROUTINE DSBMVF( UPLO, N, K, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric band matrix, with k super-diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the band matrix A is being supplied as -* follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* being supplied. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* being supplied. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of super-diagonals of the -* matrix A. K must satisfy 0 .le. K. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( K.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array A -* are accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( 1, J ) - L = 1 - J - DO 90, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) - L = 1 - J - IX = JX - IY = JY - DO 110, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSBMV . -* - END diff --git a/reference/dscalf.f b/reference/dscalf.f deleted file mode 100644 index 84d88987d..000000000 --- a/reference/dscalf.f +++ /dev/null @@ -1,43 +0,0 @@ - subroutine dscalf(n,da,dx,incx) -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision da,dx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dx(i) = da*dx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dx(i) = da*dx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dx(i) = da*dx(i) - dx(i + 1) = da*dx(i + 1) - dx(i + 2) = da*dx(i + 2) - dx(i + 3) = da*dx(i + 3) - dx(i + 4) = da*dx(i + 4) - 50 continue - return - end diff --git a/reference/dsdotf.f b/reference/dsdotf.f deleted file mode 100644 index d4e183e34..000000000 --- a/reference/dsdotf.f +++ /dev/null @@ -1,74 +0,0 @@ -*DECK DSDOT - DOUBLE PRECISION FUNCTION DSDOTF (N, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE DSDOT -C***PURPOSE Compute the inner product of two vectors with extended -C precision accumulation and result. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE DOUBLE PRECISION (DSDOT-D, DCDOT-C) -C***KEYWORDS BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT, -C LINEAR ALGEBRA, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C N number of elements in input vector(s) -C SX single precision vector with N elements -C INCX storage spacing between elements of SX -C SY single precision vector with N elements -C INCY storage spacing between elements of SY -C -C --Output-- -C DSDOT double precision dot product (zero if N.LE.0) -C -C Returns D.P. dot product accumulated in D.P., for S.P. SX and SY -C DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), -C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is -C defined in a similar way using INCY. -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920310 Corrected definition of LX in DESCRIPTION. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSDOT - REAL SX(*),SY(*) -C***FIRST EXECUTABLE STATEMENT DSDOT - DSDOTF = 0.0D0 - IF (N .LE. 0) RETURN - IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20 -C -C Code for unequal or nonpositive increments. -C - KX = 1 - KY = 1 - IF (INCX .LT. 0) KX = 1+(1-N)*INCX - IF (INCY .LT. 0) KY = 1+(1-N)*INCY - DO 10 I = 1,N - DSDOTF = DSDOTF + DBLE(SX(KX))*DBLE(SY(KY)) - KX = KX + INCX - KY = KY + INCY - 10 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 20 NS = N*INCX - DO 30 I = 1,NS,INCX - DSDOTF = DSDOTF + DBLE(SX(I))*DBLE(SY(I)) - 30 CONTINUE - RETURN - END diff --git a/reference/dspmvf.f b/reference/dspmvf.f deleted file mode 100644 index a83a6097f..000000000 --- a/reference/dspmvf.f +++ /dev/null @@ -1,262 +0,0 @@ - SUBROUTINE DSPMVF( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*AP( KK ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*AP( KK ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPMV . -* - END diff --git a/reference/dspr2f.f b/reference/dspr2f.f deleted file mode 100644 index 9eabacf5f..000000000 --- a/reference/dspr2f.f +++ /dev/null @@ -1,229 +0,0 @@ - SUBROUTINE DSPR2F( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSPR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR2 . -* - END diff --git a/reference/dsprf.f b/reference/dsprf.f deleted file mode 100644 index 69b74005f..000000000 --- a/reference/dsprf.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE DSPRF ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DSPR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR . -* - END diff --git a/reference/dswapf.f b/reference/dswapf.f deleted file mode 100644 index 597ee83fa..000000000 --- a/reference/dswapf.f +++ /dev/null @@ -1,56 +0,0 @@ - subroutine dswapf (n,dx,incx,dy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dx(ix) - dx(ix) = dy(iy) - dy(iy) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,3 - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - dtemp = dx(i + 1) - dx(i + 1) = dy(i + 1) - dy(i + 1) = dtemp - dtemp = dx(i + 2) - dx(i + 2) = dy(i + 2) - dy(i + 2) = dtemp - 50 continue - return - end diff --git a/reference/dsymmf.f b/reference/dsymmf.f deleted file mode 100644 index d0053f370..000000000 --- a/reference/dsymmf.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE DSYMMF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the symmetric matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the symmetric matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* symmetric matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* symmetric matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of DSYMM . -* - END diff --git a/reference/dsymvf.f b/reference/dsymvf.f deleted file mode 100644 index 1b38747e0..000000000 --- a/reference/dsymvf.f +++ /dev/null @@ -1,262 +0,0 @@ - SUBROUTINE DSYMVF ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( J, J ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYMV . -* - END diff --git a/reference/dsyr2f.f b/reference/dsyr2f.f deleted file mode 100644 index 826bdb01a..000000000 --- a/reference/dsyr2f.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE DSYR2F ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2 . -* - END diff --git a/reference/dsyr2kf.f b/reference/dsyr2kf.f deleted file mode 100644 index 81e73da8d..000000000 --- a/reference/dsyr2kf.f +++ /dev/null @@ -1,327 +0,0 @@ - SUBROUTINE DSYR2KF( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -* beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2K. -* - END diff --git a/reference/dsyrf.f b/reference/dsyrf.f deleted file mode 100644 index b5bcd00a5..000000000 --- a/reference/dsyrf.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE DSYRF ( UPLO, N, ALPHA, X, INCX, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DSYR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR . -* - END diff --git a/reference/dsyrkf.f b/reference/dsyrkf.f deleted file mode 100644 index 6376b0928..000000000 --- a/reference/dsyrkf.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE DSYRKF ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYRK . -* - END diff --git a/reference/dtbmvf.f b/reference/dtbmvf.f deleted file mode 100644 index da340774e..000000000 --- a/reference/dtbmvf.f +++ /dev/null @@ -1,342 +0,0 @@ - SUBROUTINE DTBMVF( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTBMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular band matrix, with ( k + 1 ) diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = KPLUS1 - J - DO 10, I = MAX( 1, J - K ), J - 1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( KPLUS1, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 30, I = MAX( 1, J - K ), J - 1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( KPLUS1, J ) - END IF - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = 1 - J - DO 50, I = MIN( N, J + K ), J + 1, -1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( 1, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 70, I = MIN( N, J + K ), J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( 1, J ) - END IF - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - L = KPLUS1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 90, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - KX = KX - INCX - IX = KX - L = KPLUS1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 110, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX - INCX - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - L = 1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 130, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - KX = KX + INCX - IX = KX - L = 1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 150, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX + INCX - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTBMV . -* - END diff --git a/reference/dtbsvf.f b/reference/dtbsvf.f deleted file mode 100644 index 4dd16d5ef..000000000 --- a/reference/dtbsvf.f +++ /dev/null @@ -1,336 +0,0 @@ - SUBROUTINE DTBSVF(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* .. Scalar Arguments .. - INTEGER INCX,K,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A(LDA,*),X(*) -* .. -* -* Purpose -* ======= -* -* DTBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Arguments -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER (ZERO=0.0D+0) -* .. -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX,MIN -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT. (K+1)) THEN - INFO = 7 - ELSE IF (INCX.EQ.0) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DTBSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - L = KPLUS1 - J - IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) - TEMP = X(J) - DO 10 I = J - 1,MAX(1,J-K),-1 - X(I) = X(I) - TEMP*A(L+I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 40 J = N,1,-1 - KX = KX - INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = KPLUS1 - J - IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) - TEMP = X(JX) - DO 30 I = J - 1,MAX(1,J-K),-1 - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - L = 1 - J - IF (NOUNIT) X(J) = X(J)/A(1,J) - TEMP = X(J) - DO 50 I = J + 1,MIN(N,J+K) - X(I) = X(I) - TEMP*A(L+I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - KX = KX + INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = 1 - J - IF (NOUNIT) X(JX) = X(JX)/A(1,J) - TEMP = X(JX) - DO 70 I = J + 1,MIN(N,J+K) - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A')*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = X(J) - L = KPLUS1 - J - DO 90 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120 J = 1,N - TEMP = X(JX) - IX = KX - L = KPLUS1 - J - DO 110 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - X(JX) = TEMP - JX = JX + INCX - IF (J.GT.K) KX = KX + INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = N,1,-1 - TEMP = X(J) - L = 1 - J - DO 130 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(I) - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - X(J) = TEMP - 140 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 160 J = N,1,-1 - TEMP = X(JX) - IX = KX - L = 1 - J - DO 150 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX - INCX - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - X(JX) = TEMP - JX = JX - INCX - IF ((N-J).GE.K) KX = KX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTBSV . -* - END diff --git a/reference/dtpmvf.f b/reference/dtpmvf.f deleted file mode 100644 index e8f6eb412..000000000 --- a/reference/dtpmvf.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE DTPMVF( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTPMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTPMVF', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x:= A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK =1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K + 1 - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK + J - 1 ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, K = KK, KK + J - 2 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK + J - 1 ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K - 1 - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK - N + J ) - END IF - KK = KK - ( N - J + 1 ) - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK - N + J ) - END IF - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - K = KK - 1 - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + AP( K )*X( I ) - K = K - 1 - 90 CONTINUE - X( J ) = TEMP - KK = KK - J - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 110, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + AP( K )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - KK = KK - J - 120 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - K = KK + 1 - DO 130, I = J + 1, N - TEMP = TEMP + AP( K )*X( I ) - K = K + 1 - 130 CONTINUE - X( J ) = TEMP - KK = KK + ( N - J + 1 ) - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 150, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + AP( K )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTPMV . -* - END diff --git a/reference/dtpsvf.f b/reference/dtpsvf.f deleted file mode 100644 index 3639ba21f..000000000 --- a/reference/dtpsvf.f +++ /dev/null @@ -1,302 +0,0 @@ - SUBROUTINE DTPSVF( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTPSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix, supplied in packed form. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTPSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK - 1 - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*AP( K ) - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 30, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK + 1 - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*AP( K ) - K = K + 1 - 50 CONTINUE - END IF - KK = KK + ( N - J + 1 ) - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - K = KK - DO 90, I = 1, J - 1 - TEMP = TEMP - AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - X( J ) = TEMP - KK = KK + J - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, K = KK, KK + J - 2 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - X( JX ) = TEMP - JX = JX + INCX - KK = KK + J - 120 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - K = KK - DO 130, I = N, J + 1, -1 - TEMP = TEMP - AP( K )*X( I ) - K = K - 1 - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - X( J ) = TEMP - KK = KK - ( N - J + 1 ) - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - X( JX ) = TEMP - JX = JX - INCX - KK = KK - (N - J + 1 ) - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTPSV . -* - END diff --git a/reference/dtrmmf.f b/reference/dtrmmf.f deleted file mode 100644 index 399d45b8d..000000000 --- a/reference/dtrmmf.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE DTRMMF ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ), -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B. -* - IF( UPPER )THEN - DO 110, J = 1, N - DO 100, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - B( I, J ) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 120, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 120 CONTINUE - B( I, J ) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 180, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 150 CONTINUE - DO 170, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 160, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 190, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 190 CONTINUE - DO 210, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 200, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A'. -* - IF( UPPER )THEN - DO 260, K = 1, N - DO 240, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 230, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 250, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300, K = N, 1, -1 - DO 280, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 270, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END diff --git a/reference/dtrmvf.f b/reference/dtrmvf.f deleted file mode 100644 index 0619d3eca..000000000 --- a/reference/dtrmvf.f +++ /dev/null @@ -1,286 +0,0 @@ - SUBROUTINE DTRMVF ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 110, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 130, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END diff --git a/reference/dtrsmf.f b/reference/dtrsmf.f deleted file mode 100644 index be3b4075a..000000000 --- a/reference/dtrsmf.f +++ /dev/null @@ -1,378 +0,0 @@ - SUBROUTINE DTRSMF ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END diff --git a/reference/dtrsvf.f b/reference/dtrsvf.f deleted file mode 100644 index 2f4a702a1..000000000 --- a/reference/dtrsvf.f +++ /dev/null @@ -1,289 +0,0 @@ - SUBROUTINE DTRSVF ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTRSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX + INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - DO 130, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSV . -* - END diff --git a/reference/dtrti2f.f b/reference/dtrti2f.f deleted file mode 100644 index 214d4f523..000000000 --- a/reference/dtrti2f.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE DTRTI2F( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTI2 computes the inverse of a real upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DTRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DTRTI2 -* - END diff --git a/reference/dtrtrif.f b/reference/dtrtrif.f deleted file mode 100644 index e2af83527..000000000 --- a/reference/dtrtrif.f +++ /dev/null @@ -1,176 +0,0 @@ - SUBROUTINE DTRTRIF( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTRI computes the inverse of a real upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = 128 - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of DTRTRI -* - END diff --git a/reference/dzamaxf.f b/reference/dzamaxf.f deleted file mode 100644 index e75cbc600..000000000 --- a/reference/dzamaxf.f +++ /dev/null @@ -1,40 +0,0 @@ - REAL*8 function dzamaxf(n,zx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - COMPLEX*16 zx(*) - integer i,incx,ix,n - double precision dcabs1 -c - dzamaxf = 0. - if( n.lt.1 .or. incx.le.0 )return - dzamaxf = dcabs1(zx(1)) - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dzamaxf = dcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(dcabs1(zx(ix)).le.dzamaxf) go to 5 - dzamaxf = i - dzamaxf = dcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dzamaxf = dcabs1(zx(1)) - do 30 i = 2,n - if(dcabs1(zx(i)).le.dzamaxf) go to 30 - dzamaxf = i - dzamaxf = dcabs1(zx(i)) - 30 continue - return - end diff --git a/reference/dzaminf.f b/reference/dzaminf.f deleted file mode 100644 index 61f59e3e0..000000000 --- a/reference/dzaminf.f +++ /dev/null @@ -1,38 +0,0 @@ - REAL*8 function dzaminf(n,zx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - COMPLEX*16 zx(*) - integer i,incx,ix,n - double precision dcabs1 -c - dzaminf = 0. - if( n.lt.1 .or. incx.le.0 )return - dzaminf = dcabs1(zx(1)) - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dzaminf = dcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(dcabs1(zx(ix)).ge.dzaminf) go to 5 - dzaminf = dcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dzaminf = dcabs1(zx(1)) - do 30 i = 2,n - if(dcabs1(zx(i)).ge.dzaminf) go to 30 - dzaminf = dcabs1(zx(i)) - 30 continue - return - end diff --git a/reference/dzasumf.f b/reference/dzasumf.f deleted file mode 100644 index 1b4dbdb45..000000000 --- a/reference/dzasumf.f +++ /dev/null @@ -1,34 +0,0 @@ - double precision function dzasumf(n,zx,incx) -c -c takes the sum of the absolute values. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision stemp,dcabs1 - integer i,incx,ix,n -c - dzasumf = 0.0d0 - stemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - stemp = stemp + dcabs1(zx(ix)) - ix = ix + incx - 10 continue - dzasumf = stemp - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - stemp = stemp + dcabs1(zx(i)) - 30 continue - dzasumf = stemp - return - end diff --git a/reference/dznrm2f.f b/reference/dznrm2f.f deleted file mode 100644 index 1e9cba68e..000000000 --- a/reference/dznrm2f.f +++ /dev/null @@ -1,67 +0,0 @@ - DOUBLE PRECISION FUNCTION DZNRM2F( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* DZNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DZNRM2 := sqrt( conjg( x' )*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to ZLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION NORM, SCALE, SSQ, TEMP -* .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DBLE, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( DBLE( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( DBLE( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - IF( DIMAG( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( DIMAG( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DZNRM2F = NORM - RETURN -* -* End of DZNRM2. -* - END diff --git a/reference/icamaxf.f b/reference/icamaxf.f deleted file mode 100644 index 928ad32fc..000000000 --- a/reference/icamaxf.f +++ /dev/null @@ -1,41 +0,0 @@ - integer function icamaxf(n,cx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*) - real smax - integer i,incx,ix,n - real scabs1 -c - icamaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - icamaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = scabs1(cx(1)) - ix = ix + incx - do 10 i = 2,n - if(scabs1(cx(ix)).le.smax) go to 5 - icamaxf = i - smax = scabs1(cx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = scabs1(cx(1)) - do 30 i = 2,n - if(scabs1(cx(i)).le.smax) go to 30 - icamaxf = i - smax = scabs1(cx(i)) - 30 continue - return - end diff --git a/reference/icaminf.f b/reference/icaminf.f deleted file mode 100644 index 353545068..000000000 --- a/reference/icaminf.f +++ /dev/null @@ -1,41 +0,0 @@ - integer function icaminf(n,cx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*) - real smin - integer i,incx,ix,n - real scabs1 -c - icaminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - icaminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smin = scabs1(cx(1)) - ix = ix + incx - do 10 i = 2,n - if(scabs1(cx(ix)).ge.smin) go to 5 - icaminf = i - smin = scabs1(cx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smin = scabs1(cx(1)) - do 30 i = 2,n - if(scabs1(cx(i)).ge.smin) go to 30 - icaminf = i - smin = scabs1(cx(i)) - 30 continue - return - end diff --git a/reference/idamaxf.f b/reference/idamaxf.f deleted file mode 100644 index e1359e542..000000000 --- a/reference/idamaxf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function idamaxf(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmax - integer i,incx,ix,n -c - idamaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - idamaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.dmax) go to 5 - idamaxf = i - dmax = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.dmax) go to 30 - idamaxf = i - dmax = dabs(dx(i)) - 30 continue - return - end diff --git a/reference/idaminf.f b/reference/idaminf.f deleted file mode 100644 index 86e18cb8a..000000000 --- a/reference/idaminf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function idaminf(n,dx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmin - integer i,incx,ix,n -c - idaminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - idaminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmin = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).ge.dmin) go to 5 - idaminf = i - dmin = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmin = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).ge.dmin) go to 30 - idaminf = i - dmin = dabs(dx(i)) - 30 continue - return - end diff --git a/reference/idmaxf.f b/reference/idmaxf.f deleted file mode 100644 index 9b0d25c16..000000000 --- a/reference/idmaxf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function idmaxf(n,dx,incx) -c -c finds the index of element having max. value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmax - integer i,incx,ix,n -c - idmaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - idmaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dx(1) - ix = ix + incx - do 10 i = 2,n - if(dx(ix).le.dmax) go to 5 - idmaxf = i - dmax = dx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dx(1) - do 30 i = 2,n - if(dx(i).le.dmax) go to 30 - idmaxf = i - dmax = dx(i) - 30 continue - return - end diff --git a/reference/idminf.f b/reference/idminf.f deleted file mode 100644 index 4ba0b5e6c..000000000 --- a/reference/idminf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function idminf(n,dx,incx) -c -c finds the index of element having min. value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmin - integer i,incx,ix,n -c - idminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - idminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmin = dx(1) - ix = ix + incx - do 10 i = 2,n - if(dx(ix).ge.dmin) go to 5 - idminf = i - dmin = dx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmin = dx(1) - do 30 i = 2,n - if(dx(i).ge.dmin) go to 30 - idminf = i - dmin = dx(i) - 30 continue - return - end diff --git a/reference/iqamaxf.f b/reference/iqamaxf.f deleted file mode 100644 index 13e9fc71e..000000000 --- a/reference/iqamaxf.f +++ /dev/null @@ -1,48 +0,0 @@ - REAL*10 function qabs(dx) - REAL*10 dx - - qabs = dx - if (dx >= 0) return - qabs = -dx - return - end - - integer function iqamaxf(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real*10 dx(*),dmax - integer i,incx,ix,n -c - iqamaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - iqamaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = qabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(qabs(dx(ix)).le.dmax) go to 5 - iqamaxf = i - dmax = qabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = qabs(dx(1)) - do 30 i = 2,n - if(qabs(dx(i)).le.dmax) go to 30 - iqamaxf = i - dmax = qabs(dx(i)) - 30 continue - return - end diff --git a/reference/iqaminf.f b/reference/iqaminf.f deleted file mode 100644 index 1429be7fb..000000000 --- a/reference/iqaminf.f +++ /dev/null @@ -1,49 +0,0 @@ - REAL*10 function qabs(dx) - REAL*10 dx - - qabs = dx - if (dx >= 0) return - qabs = -dx - return - end - - - integer function iqaminf(n,dx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real*10 dx(*),dmin - integer i,incx,ix,n -c - iqaminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - iqaminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmin = qabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(qabs(dx(ix)).ge.dmin) go to 5 - iqaminf = i - dmin = qabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmin = qabs(dx(1)) - do 30 i = 2,n - if(qabs(dx(i)).ge.dmin) go to 30 - iqaminf = i - dmin = qabs(dx(i)) - 30 continue - return - end diff --git a/reference/iqmaxf.f b/reference/iqmaxf.f deleted file mode 100644 index 782e4f2cd..000000000 --- a/reference/iqmaxf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function iqmaxf(n,dx,incx) -c -c finds the index of element having max. value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real*10 dx(*),dmax - integer i,incx,ix,n -c - iqmaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - iqmaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dx(1) - ix = ix + incx - do 10 i = 2,n - if(dx(ix).le.dmax) go to 5 - iqmaxf = i - dmax = dx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dx(1) - do 30 i = 2,n - if(dx(i).le.dmax) go to 30 - iqmaxf = i - dmax = dx(i) - 30 continue - return - end diff --git a/reference/iqminf.f b/reference/iqminf.f deleted file mode 100644 index bc75c2bcb..000000000 --- a/reference/iqminf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function iqminf(n,dx,incx) -c -c finds the index of element having min. value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real*10 dx(*),dmin - integer i,incx,ix,n -c - iqminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - iqminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmin = dx(1) - ix = ix + incx - do 10 i = 2,n - if(dx(ix).ge.dmin) go to 5 - iqminf = i - dmin = dx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmin = dx(1) - do 30 i = 2,n - if(dx(i).ge.dmin) go to 30 - iqminf = i - dmin = dx(i) - 30 continue - return - end diff --git a/reference/isamaxf.f b/reference/isamaxf.f deleted file mode 100644 index 95be5a55a..000000000 --- a/reference/isamaxf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function isamaxf(n,sx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),smax - integer i,incx,ix,n -c - isamaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - isamaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = abs(sx(1)) - ix = ix + incx - do 10 i = 2,n - if(abs(sx(ix)).le.smax) go to 5 - isamaxf = i - smax = abs(sx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = abs(sx(1)) - do 30 i = 2,n - if(abs(sx(i)).le.smax) go to 30 - isamaxf = i - smax = abs(sx(i)) - 30 continue - return - end diff --git a/reference/isaminf.f b/reference/isaminf.f deleted file mode 100644 index 83eb129d5..000000000 --- a/reference/isaminf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function isaminf(n,sx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),smin - integer i,incx,ix,n -c - isaminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - isaminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smin = abs(sx(1)) - ix = ix + incx - do 10 i = 2,n - if(abs(sx(ix)).ge.smin) go to 5 - isaminf = i - smin = abs(sx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smin = abs(sx(1)) - do 30 i = 2,n - if(abs(sx(i)).ge.smin) go to 30 - isaminf = i - smin = abs(sx(i)) - 30 continue - return - end diff --git a/reference/ismaxf.f b/reference/ismaxf.f deleted file mode 100644 index 63cab5f77..000000000 --- a/reference/ismaxf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function ismaxf(n,sx,incx) -c -c finds the index of element having max. value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),smax - integer i,incx,ix,n -c - ismaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - ismaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = sx(1) - ix = ix + incx - do 10 i = 2,n - if(sx(ix).le.smax) go to 5 - ismaxf = i - smax = sx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = sx(1) - do 30 i = 2,n - if(sx(i).le.smax) go to 30 - ismaxf = i - smax = sx(i) - 30 continue - return - end diff --git a/reference/isminf.f b/reference/isminf.f deleted file mode 100644 index dc5980175..000000000 --- a/reference/isminf.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function isminf(n,sx,incx) -c -c finds the index of element having min. value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),smin - integer i,incx,ix,n -c - isminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - isminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smin = sx(1) - ix = ix + incx - do 10 i = 2,n - if(sx(ix).ge.smin) go to 5 - isminf = i - smin = sx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smin = sx(1) - do 30 i = 2,n - if(sx(i).ge.smin) go to 30 - isminf = i - smin = sx(i) - 30 continue - return - end diff --git a/reference/ixamaxf.f b/reference/ixamaxf.f deleted file mode 100644 index 536602f05..000000000 --- a/reference/ixamaxf.f +++ /dev/null @@ -1,41 +0,0 @@ - integer function ixamaxf(n,zx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex*20 zx(*) - real*10 smax - integer i,incx,ix,n - real*10 qcabs1 -c - ixamaxf = 0 - if( n.lt.1 .or. incx.le.0 )return - ixamaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = qcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(qcabs1(zx(ix)).le.smax) go to 5 - ixamaxf = i - smax = qcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = qcabs1(zx(1)) - do 30 i = 2,n - if(qcabs1(zx(i)).le.smax) go to 30 - ixamaxf = i - smax = qcabs1(zx(i)) - 30 continue - return - end diff --git a/reference/ixaminf.f b/reference/ixaminf.f deleted file mode 100644 index 8112e8b97..000000000 --- a/reference/ixaminf.f +++ /dev/null @@ -1,41 +0,0 @@ - integer function ixaminf(n,zx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex*20 zx(*) - real*10 smin - integer i,incx,ix,n - real*10 qcabs1 -c - ixaminf = 0 - if( n.lt.1 .or. incx.le.0 )return - ixaminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smin = qcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(qcabs1(zx(ix)).ge.smin) go to 5 - ixaminf = i - smin = qcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smin = qcabs1(zx(1)) - do 30 i = 2,n - if(qcabs1(zx(i)).ge.smin) go to 30 - ixaminf = i - smin = qcabs1(zx(i)) - 30 continue - return - end diff --git a/reference/izamaxf.f b/reference/izamaxf.f deleted file mode 100644 index 902c014a4..000000000 --- a/reference/izamaxf.f +++ /dev/null @@ -1,41 +0,0 @@ - integer function izamaxf(n,zx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision smax - integer i,incx,ix,n - double precision dcabs1 -c - izamaxf = 0 - if( n.lt.1 .or. incx.le.0 )return - izamaxf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = dcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(dcabs1(zx(ix)).le.smax) go to 5 - izamaxf = i - smax = dcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = dcabs1(zx(1)) - do 30 i = 2,n - if(dcabs1(zx(i)).le.smax) go to 30 - izamaxf = i - smax = dcabs1(zx(i)) - 30 continue - return - end diff --git a/reference/izaminf.f b/reference/izaminf.f deleted file mode 100644 index 877984937..000000000 --- a/reference/izaminf.f +++ /dev/null @@ -1,41 +0,0 @@ - integer function izaminf(n,zx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision smin - integer i,incx,ix,n - double precision dcabs1 -c - izaminf = 0 - if( n.lt.1 .or. incx.le.0 )return - izaminf = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smin = dcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(dcabs1(zx(ix)).ge.smin) go to 5 - izaminf = i - smin = dcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smin = dcabs1(zx(1)) - do 30 i = 2,n - if(dcabs1(zx(i)).ge.smin) go to 30 - izaminf = i - smin = dcabs1(zx(i)) - 30 continue - return - end diff --git a/reference/lsamef.f b/reference/lsamef.f deleted file mode 100644 index f89517460..000000000 --- a/reference/lsamef.f +++ /dev/null @@ -1,87 +0,0 @@ - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* January 31, 1994 -* -* .. Scalar Arguments .. - CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* 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 diff --git a/reference/samaxf.f b/reference/samaxf.f deleted file mode 100644 index ef0b80f4d..000000000 --- a/reference/samaxf.f +++ /dev/null @@ -1,36 +0,0 @@ - REAL*4 function samaxf(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL*4 dx(*) - integer i,incx,ix,n -c - samaxf = 0. - if( n.lt.1 .or. incx.le.0 ) return - - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - samaxf = abs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(abs(dx(ix)).le.samaxf) go to 5 - samaxf = abs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 samaxf = abs(dx(1)) - do 30 i = 2,n - if(abs(dx(i)).le.samaxf) go to 30 - samaxf = abs(dx(i)) - 30 continue - return - end diff --git a/reference/saminf.f b/reference/saminf.f deleted file mode 100644 index 455436b29..000000000 --- a/reference/saminf.f +++ /dev/null @@ -1,36 +0,0 @@ - REAL*4 function saminf(n,dx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL*4 dx(*) - integer i,incx,ix,n -c - saminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - saminf = abs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(abs(dx(ix)).ge.saminf) go to 5 - saminf = abs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 saminf = abs(dx(1)) - do 30 i = 2,n - if(abs(dx(i)).ge.saminf) go to 30 - saminf = abs(dx(i)) - 30 continue - return - end diff --git a/reference/sasumf.f b/reference/sasumf.f deleted file mode 100644 index bf3805b40..000000000 --- a/reference/sasumf.f +++ /dev/null @@ -1,44 +0,0 @@ - real function sasumf(n,sx,incx) -c -c takes the sum of the absolute values. -c uses unrolled loops for increment equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),stemp - integer i,incx,m,mp1,n,nincx -c - sasumf = 0.0e0 - stemp = 0.0e0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - stemp = stemp + abs(sx(i)) - 10 continue - sasumf = stemp - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,6) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - stemp = stemp + abs(sx(i)) - 30 continue - if( n .lt. 6 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,6 - stemp = stemp + abs(sx(i)) + abs(sx(i + 1)) + abs(sx(i + 2)) - * + abs(sx(i + 3)) + abs(sx(i + 4)) + abs(sx(i + 5)) - 50 continue - 60 sasumf = stemp - return - end diff --git a/reference/saxpyf.f b/reference/saxpyf.f deleted file mode 100644 index 95f1e01db..000000000 --- a/reference/saxpyf.f +++ /dev/null @@ -1,48 +0,0 @@ - subroutine saxpyf(n,sa,sx,incx,sy,incy) -c -c constant times a vector plus a vector. -c uses unrolled loop for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),sy(*),sa - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if (sa .eq. 0.0) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - sy(iy) = sy(iy) + sa*sx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,4) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - sy(i) = sy(i) + sa*sx(i) - 30 continue - if( n .lt. 4 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,4 - sy(i) = sy(i) + sa*sx(i) - sy(i + 1) = sy(i + 1) + sa*sx(i + 1) - sy(i + 2) = sy(i + 2) + sa*sx(i + 2) - sy(i + 3) = sy(i + 3) + sa*sx(i + 3) - 50 continue - return - end diff --git a/reference/scamaxf.f b/reference/scamaxf.f deleted file mode 100644 index f3d0a5149..000000000 --- a/reference/scamaxf.f +++ /dev/null @@ -1,40 +0,0 @@ - REAL*4 function scamaxf(n,zx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - COMPLEX*8 zx(*) - integer i,incx,ix,n - REAL*4 scabs1 -c - scamaxf = 0. - if( n.lt.1 .or. incx.le.0 )return - scamaxf = scabs1(zx(1)) - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - scamaxf = scabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(scabs1(zx(ix)).le.scamaxf) go to 5 - scamaxf = i - scamaxf = scabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 scamaxf = scabs1(zx(1)) - do 30 i = 2,n - if(scabs1(zx(i)).le.scamaxf) go to 30 - scamaxf = i - scamaxf = scabs1(zx(i)) - 30 continue - return - end diff --git a/reference/scaminf.f b/reference/scaminf.f deleted file mode 100644 index e6a6e91c5..000000000 --- a/reference/scaminf.f +++ /dev/null @@ -1,38 +0,0 @@ - REAL*4 function scaminf(n,zx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - COMPLEX*8 zx(*) - integer i,incx,ix,n - REAL*4 scabs1 -c - scaminf = 0. - if( n.lt.1 .or. incx.le.0 )return - scaminf = scabs1(zx(1)) - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - scaminf = scabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(scabs1(zx(ix)).ge.scaminf) go to 5 - scaminf = scabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 scaminf = scabs1(zx(1)) - do 30 i = 2,n - if(scabs1(zx(i)).ge.scaminf) go to 30 - scaminf = scabs1(zx(i)) - 30 continue - return - end diff --git a/reference/scasumf.f b/reference/scasumf.f deleted file mode 100644 index 6cc139f14..000000000 --- a/reference/scasumf.f +++ /dev/null @@ -1,34 +0,0 @@ - real function scasumf(n,cx,incx) -c -c takes the sum of the absolute values of a complex vector and -c returns a single precision result. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*) - real stemp - integer i,incx,n,nincx -c - scasumf = 0.0e0 - stemp = 0.0e0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i))) - 10 continue - scasumf = stemp - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i))) - 30 continue - scasumf = stemp - return - end diff --git a/reference/scnrm2f.f b/reference/scnrm2f.f deleted file mode 100644 index d7e0b379b..000000000 --- a/reference/scnrm2f.f +++ /dev/null @@ -1,67 +0,0 @@ - REAL FUNCTION SCNRM2F( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - COMPLEX X( * ) -* .. -* -* SCNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* SCNRM2 := sqrt( conjg( x' )*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to CLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. Local Scalars .. - INTEGER IX - REAL NORM, SCALE, SSQ, TEMP -* .. Intrinsic Functions .. - INTRINSIC ABS, AIMAG, REAL, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL CLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( REAL( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( REAL( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - IF( AIMAG( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( AIMAG( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - SCNRM2F = NORM - RETURN -* -* End of SCNRM2. -* - END diff --git a/reference/scopyf.f b/reference/scopyf.f deleted file mode 100644 index bec15844d..000000000 --- a/reference/scopyf.f +++ /dev/null @@ -1,50 +0,0 @@ - subroutine scopyf(n,sx,incx,sy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to 1. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),sy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - sy(iy) = sx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - sy(i) = sx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - sy(i) = sx(i) - sy(i + 1) = sx(i + 1) - sy(i + 2) = sx(i + 2) - sy(i + 3) = sx(i + 3) - sy(i + 4) = sx(i + 4) - sy(i + 5) = sx(i + 5) - sy(i + 6) = sx(i + 6) - 50 continue - return - end diff --git a/reference/sdotf.f b/reference/sdotf.f deleted file mode 100644 index dabda7c4c..000000000 --- a/reference/sdotf.f +++ /dev/null @@ -1,49 +0,0 @@ - real function sdotf(n,sx,incx,sy,incy) -c -c forms the dot product of two vectors. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),sy(*),stemp - integer i,incx,incy,ix,iy,m,mp1,n -c - stemp = 0.0e0 - sdotf = 0.0e0 - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - stemp = stemp + sx(ix)*sy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - sdotf = stemp - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - stemp = stemp + sx(i)*sy(i) - 30 continue - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) + - * sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4) - 50 continue - 60 sdotf = stemp - return - end diff --git a/reference/sdsdotf.f b/reference/sdsdotf.f deleted file mode 100644 index c3aa6a53b..000000000 --- a/reference/sdsdotf.f +++ /dev/null @@ -1,78 +0,0 @@ -*DECK SDSDOTF - REAL FUNCTION SDSDOTF (N, SB, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE SDSDOT -C***PURPOSE Compute the inner product of two vectors with extended -C precision accumulation. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE SINGLE PRECISION (SDSDOT-S, CDCDOT-C) -C***KEYWORDS BLAS, DOT PRODUCT, INNER PRODUCT, LINEAR ALGEBRA, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C N number of elements in input vector(s) -C SB single precision scalar to be added to inner product -C SX single precision vector with N elements -C INCX storage spacing between elements of SX -C SY single precision vector with N elements -C INCY storage spacing between elements of SY -C -C --Output-- -C SDSDOT single precision dot product (SB if N .LE. 0) -C -C Returns S.P. result with dot product accumulated in D.P. -C SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY), -C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is -C defined in a similar way using INCY. -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920310 Corrected definition of LX in DESCRIPTION. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE SDSDOT - REAL SX(*), SY(*), SB - DOUBLE PRECISION DSDOT -C***FIRST EXECUTABLE STATEMENT SDSDOT - DSDOT = SB - IF (N .LE. 0) GO TO 30 - IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 40 -C -C Code for unequal or nonpositive increments. -C - KX = 1 - KY = 1 - IF (INCX .LT. 0) KX = 1+(1-N)*INCX - IF (INCY .LT. 0) KY = 1+(1-N)*INCY - DO 10 I = 1,N - DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) - KX = KX + INCX - KY = KY + INCY - 10 CONTINUE - 30 SDSDOTF = DSDOT - RETURN -C -C Code for equal and positive increments. -C - 40 NS = N*INCX - DO 50 I = 1,NS,INCX - DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) - 50 CONTINUE - SDSDOTF = DSDOT - RETURN - END diff --git a/reference/sgbmvf.f b/reference/sgbmvf.f deleted file mode 100644 index c8bc9ff09..000000000 --- a/reference/sgbmvf.f +++ /dev/null @@ -1,300 +0,0 @@ - SUBROUTINE SGBMVF( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SGBMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n band matrix, with kl sub-diagonals and ku super-diagonals. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* KL - INTEGER. -* On entry, KL specifies the number of sub-diagonals of the -* matrix A. KL must satisfy 0 .le. KL. -* Unchanged on exit. -* -* KU - INTEGER. -* On entry, KU specifies the number of super-diagonals of the -* matrix A. KU must satisfy 0 .le. KU. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry, the leading ( kl + ku + 1 ) by n part of the -* array A must contain the matrix of coefficients, supplied -* column by column, with the leading diagonal of the matrix in -* row ( ku + 1 ) of the array, the first super-diagonal -* starting at position 2 in row ku, the first sub-diagonal -* starting at position 1 in row ( ku + 2 ), and so on. -* Elements in the array A that do not correspond to elements -* in the band matrix (such as the top left ku by ku triangle) -* are not referenced. -* The following program segment will transfer a band matrix -* from conventional full matrix storage to band storage: -* -* DO 20, J = 1, N -* K = KU + 1 - J -* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -* A( K + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( kl + ku + 1 ). -* Unchanged on exit. -* -* X - REAL array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - REAL array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( KL.LT.0 )THEN - INFO = 4 - ELSE IF( KU.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN - INFO = 8 - ELSE IF( INCX.EQ.0 )THEN - INFO = 10 - ELSE IF( INCY.EQ.0 )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SGBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the band part of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KUP1 = KU + 1 - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - K = KUP1 - J - DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - K = KUP1 - J - DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - K = KUP1 - J - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of SGBMV . -* - END diff --git a/reference/sgemmf.f b/reference/sgemmf.f deleted file mode 100644 index ebb50c3af..000000000 --- a/reference/sgemmf.f +++ /dev/null @@ -1,313 +0,0 @@ - SUBROUTINE SGEMMF(TRANA,TRANB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* .. Scalar Arguments .. - REAL ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANA,TRANB -* .. -* .. Array Arguments .. - REAL A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* Purpose -* ======= -* -* SGEMM 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', -* -* 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. -* -* Arguments -* ========== -* -* TRANA - CHARACTER*1. -* On entry, TRANA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANA = 'N' or 'n', op( A ) = A. -* -* TRANA = 'T' or 't', op( A ) = A'. -* -* TRANA = 'C' or 'c', op( A ) = A'. -* -* Unchanged on exit. -* -* TRANB - CHARACTER*1. -* On entry, TRANB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANB = 'N' or 'n', op( B ) = B. -* -* TRANB = 'T' or 't', op( B ) = B'. -* -* TRANB = 'C' or 'c', op( B ) = B'. -* -* Unchanged on exit. -* -* M - 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. -* Unchanged on exit. -* -* N - 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. -* Unchanged on exit. -* -* K - 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. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, ka ), where ka is -* k when TRANA = 'N' or 'n', and is m otherwise. -* Before entry with TRANA = '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. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - REAL array of DIMENSION ( LDB, kb ), where kb is -* n when TRANB = 'N' or 'n', and is k otherwise. -* Before entry with TRANB = '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. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - REAL array of 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 ). -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Local Scalars .. - REAL TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL NOTA,NOTB -* .. -* .. Parameters .. - REAL ONE,ZERO - PARAMETER (ONE=1.0E+0,ZERO=0.0E+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(TRANA,'N') - NOTB = LSAME(TRANB,'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(TRANA,'C')) .AND. - + (.NOT.LSAME(TRANA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANB,'C')) .AND. - + (.NOT.LSAME(TRANB,'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('SGEMM ',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 - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*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' + 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 - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 150 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + 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 SGEMM . -* - END diff --git a/reference/sgemvf.f b/reference/sgemvf.f deleted file mode 100644 index 351da45ff..000000000 --- a/reference/sgemvf.f +++ /dev/null @@ -1,257 +0,0 @@ - SUBROUTINE SGEMVF ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - REAL array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - REAL array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - DO 110, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of SGEMV . -* - END diff --git a/reference/sgerf.f b/reference/sgerf.f deleted file mode 100644 index f84c93328..000000000 --- a/reference/sgerf.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE SGERF ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SGER performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SGER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of SGER . -* - END diff --git a/reference/sgesvf.f b/reference/sgesvf.f deleted file mode 100644 index 8d313abde..000000000 --- a/reference/sgesvf.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE SGESVF( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* SGESV computes the solution to a real system of linear equations -* A * X = B, -* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as -* A = P * L * U, -* where P is a permutation matrix, L is unit lower triangular, and U is -* upper triangular. The factored form of A is then used to solve the -* system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the N-by-N coefficient matrix A. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) REAL array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS matrix of right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, so the solution could not be computed. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL SGETRF, SGETRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL SGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL SGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of SGESV -* - END diff --git a/reference/sgetf2f.f b/reference/sgetf2f.f deleted file mode 100644 index 15861b131..000000000 --- a/reference/sgetf2f.f +++ /dev/null @@ -1,135 +0,0 @@ - SUBROUTINE SGETF2F( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* SGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER ISAMAX - EXTERNAL ISAMAX -* .. -* .. External Subroutines .. - EXTERNAL SGER, SSCAL, SSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + ISAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL SSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL SSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL SGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of SGETF2 -* - END diff --git a/reference/sgetrff.f b/reference/sgetrff.f deleted file mode 100644 index 892386949..000000000 --- a/reference/sgetrff.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE SGETRFF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* SGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL SGEMM, SGETF2, SLASWP, STRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 64 - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL SGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL SGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL SGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of SGETRF -* - END diff --git a/reference/sgetrsf.f b/reference/sgetrsf.f deleted file mode 100644 index 0f14aedd9..000000000 --- a/reference/sgetrsf.f +++ /dev/null @@ -1,150 +0,0 @@ - SUBROUTINE SGETRSF( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* SGETRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by SGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) REAL array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by SGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from SGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) REAL array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL SLASWP, STRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A' * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL STRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of SGETRS -* - END diff --git a/reference/slaswpf.f b/reference/slaswpf.f deleted file mode 100644 index ab300e298..000000000 --- a/reference/slaswpf.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE SLASWPF( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* SLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - REAL TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of SLASWP -* - END diff --git a/reference/slauu2f.f b/reference/slauu2f.f deleted file mode 100644 index 5d48e1202..000000000 --- a/reference/slauu2f.f +++ /dev/null @@ -1,135 +0,0 @@ - SUBROUTINE SLAUU2F( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* SLAUU2 computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the unblocked form of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - REAL AII -* .. -* .. External Functions .. - LOGICAL LSAME - REAL SDOT - EXTERNAL LSAME, SDOT -* .. -* .. External Subroutines .. - EXTERNAL SGEMV, SSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SLAUU2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = SDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA ) - CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 ) - ELSE - CALL SSCAL( I, AII, A( 1, I ), 1 ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = SDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 ) - CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, AII, A( I, 1 ), LDA ) - ELSE - CALL SSCAL( I, AII, A( I, 1 ), LDA ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of SLAUU2 -* - END diff --git a/reference/slauumf.f b/reference/slauumf.f deleted file mode 100644 index a4b25b985..000000000 --- a/reference/slauumf.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE SLAUUMF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* SLAUUM computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the blocked form of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL SGEMM, SLAUU2, SSYRK, STRMM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SLAUUM', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 128 -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL SLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL STRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', - $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ), - $ LDA ) - CALL SLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL SGEMM( 'No transpose', 'Transpose', I-1, IB, - $ N-I-IB+1, ONE, A( 1, I+IB ), LDA, - $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA ) - CALL SSYRK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL STRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB, - $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA ) - CALL SLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL SGEMM( 'Transpose', 'No transpose', IB, I-1, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA ) - CALL SSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE, - $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF -* - RETURN -* -* End of SLAUUM -* - END diff --git a/reference/smaxf.f b/reference/smaxf.f deleted file mode 100644 index 69d473843..000000000 --- a/reference/smaxf.f +++ /dev/null @@ -1,36 +0,0 @@ - REAL*4 function smaxf(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL*4 dx(*) - integer i,incx,ix,n -c - smaxf = 0 - if( n.lt.1 .or. incx.le.0 ) return - - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smaxf = dx(1) - ix = ix + incx - do 10 i = 2,n - if(dx(ix).le.smaxf) go to 5 - smaxf = dx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smaxf = dx(1) - do 30 i = 2,n - if(dx(i).le.smaxf) go to 30 - smaxf = dx(i) - 30 continue - return - end diff --git a/reference/sminf.f b/reference/sminf.f deleted file mode 100644 index de59c2e36..000000000 --- a/reference/sminf.f +++ /dev/null @@ -1,36 +0,0 @@ - REAL*4 function sminf(n,dx,incx) -c -c finds the index of element having min. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - REAL*4 dx(*) - integer i,incx,ix,n -c - sminf = 0 - if( n.lt.1 .or. incx.le.0 ) return - - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - sminf = dx(1) - ix = ix + incx - do 10 i = 2,n - if(dx(ix).ge.sminf) go to 5 - sminf = dx(ix) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 sminf = dx(1) - do 30 i = 2,n - if(dx(i).ge.sminf) go to 30 - sminf = dx(i) - 30 continue - return - end diff --git a/reference/snrm2f.f b/reference/snrm2f.f deleted file mode 100644 index cff495d20..000000000 --- a/reference/snrm2f.f +++ /dev/null @@ -1,60 +0,0 @@ - REAL FUNCTION SNRM2F ( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - REAL X( * ) -* .. -* -* SNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* SNRM2 := sqrt( x'*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to SLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. Local Scalars .. - INTEGER IX - REAL ABSXI, NORM, SCALE, SSQ -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE IF( N.EQ.1 )THEN - NORM = ABS( X( 1 ) ) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL SLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SSQ = ONE + SSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - SNRM2F = NORM - RETURN -* -* End of SNRM2. -* - END diff --git a/reference/spotf2f.f b/reference/spotf2f.f deleted file mode 100644 index 5662b803b..000000000 --- a/reference/spotf2f.f +++ /dev/null @@ -1,168 +0,0 @@ - SUBROUTINE SPOTF2F( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* SPOTF2 computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - REAL AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - REAL SDOT - EXTERNAL LSAME, SDOT -* .. -* .. External Subroutines .. - EXTERNAL SGEMV, SSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - SDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL SGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) - CALL SSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - SDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), - $ LDA ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL SGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) - CALL SSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of SPOTF2 -* - END diff --git a/reference/spotrff.f b/reference/spotrff.f deleted file mode 100644 index 7297c81bc..000000000 --- a/reference/spotrff.f +++ /dev/null @@ -1,184 +0,0 @@ - SUBROUTINE SPOTRFF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* SPOTRF computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U**T * U, if UPLO = 'U', or -* A = L * L**T, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL SGEMM, SPOTF2, SSYRK, STRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 56 - - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL SPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL SSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL SPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL SGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, - $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), - $ LDA, ONE, A( J, J+JB ), LDA ) - CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, - $ A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL SSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL SPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), - $ LDA, ONE, A( J+JB, J ), LDA ) - CALL STRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-J-JB+1, JB, ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of SPOTRF -* - END diff --git a/reference/spotrif.f b/reference/spotrif.f deleted file mode 100644 index ad24e2345..000000000 --- a/reference/spotrif.f +++ /dev/null @@ -1,96 +0,0 @@ - SUBROUTINE SPOTRIF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* SPOTRI computes the inverse of a real symmetric positive definite -* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T -* computed by SPOTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the triangular factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T, as computed by -* SPOTRF. -* On exit, the upper or lower triangle of the (symmetric) -* inverse of A, overwriting the input factor U or L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the (i,i) element of the factor U or L is -* zero, and the inverse could not be computed. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL SLAUUM, STRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'SPOTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Invert the triangular Cholesky factor U or L. -* - CALL STRTRI( UPLO, 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* -* Form inv(U)*inv(U)' or inv(L)'*inv(L). -* - CALL SLAUUM( UPLO, N, A, LDA, INFO ) -* - RETURN -* -* End of SPOTRI -* - END diff --git a/reference/srotf.f b/reference/srotf.f deleted file mode 100644 index 02230800c..000000000 --- a/reference/srotf.f +++ /dev/null @@ -1,37 +0,0 @@ - subroutine srotf (n,sx,incx,sy,incy,c,s) -c -c applies a plane rotation. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),sy(*),stemp,c,s - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - stemp = c*sx(ix) + s*sy(iy) - sy(iy) = c*sy(iy) - s*sx(ix) - sx(ix) = stemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - stemp = c*sx(i) + s*sy(i) - sy(i) = c*sy(i) - s*sx(i) - sx(i) = stemp - 30 continue - return - end diff --git a/reference/srotgf.f b/reference/srotgf.f deleted file mode 100644 index 4f222988c..000000000 --- a/reference/srotgf.f +++ /dev/null @@ -1,27 +0,0 @@ - subroutine srotgf(sa,sb,c,s) -c -c construct givens plane rotation. -c jack dongarra, linpack, 3/11/78. -c - real sa,sb,c,s,roe,scale,r,z -c - roe = sb - if( abs(sa) .gt. abs(sb) ) roe = sa - scale = abs(sa) + abs(sb) - if( scale .ne. 0.0 ) go to 10 - c = 1.0 - s = 0.0 - r = 0.0 - z = 0.0 - go to 20 - 10 r = scale*sqrt((sa/scale)**2 + (sb/scale)**2) - r = sign(1.0,roe)*r - c = sa/r - s = sb/r - z = 1.0 - if( abs(sa) .gt. abs(sb) ) z = s - if( abs(sb) .ge. abs(sa) .and. c .ne. 0.0 ) z = 1.0/c - 20 sa = r - sb = z - return - end diff --git a/reference/srotmf.f b/reference/srotmf.f deleted file mode 100644 index 3924edbc2..000000000 --- a/reference/srotmf.f +++ /dev/null @@ -1,106 +0,0 @@ - SUBROUTINE SROTMF (N,SX,INCX,SY,INCY,SPARAM) -C -C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX -C -C (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN -C (DX**T) -C -C SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE -C LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. -C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. -C -C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 -C -C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) -C H=( ) ( ) ( ) ( ) -C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). -C SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM. -C - DIMENSION SX(1),SY(1),SPARAM(5) - DATA ZERO,TWO/0.E0,2.E0/ -C - SFLAG=SPARAM(1) - IF(N .LE. 0 .OR.(SFLAG+TWO.EQ.ZERO)) GO TO 140 - IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 -C - NSTEPS=N*INCX - IF(SFLAG) 50,10,30 - 10 CONTINUE - SH12=SPARAM(4) - SH21=SPARAM(3) - DO 20 I=1,NSTEPS,INCX - W=SX(I) - Z=SY(I) - SX(I)=W+Z*SH12 - SY(I)=W*SH21+Z - 20 CONTINUE - GO TO 140 - 30 CONTINUE - SH11=SPARAM(2) - SH22=SPARAM(5) - DO 40 I=1,NSTEPS,INCX - W=SX(I) - Z=SY(I) - SX(I)=W*SH11+Z - SY(I)=-W+SH22*Z - 40 CONTINUE - GO TO 140 - 50 CONTINUE - SH11=SPARAM(2) - SH12=SPARAM(4) - SH21=SPARAM(3) - SH22=SPARAM(5) - DO 60 I=1,NSTEPS,INCX - W=SX(I) - Z=SY(I) - SX(I)=W*SH11+Z*SH12 - SY(I)=W*SH21+Z*SH22 - 60 CONTINUE - GO TO 140 - 70 CONTINUE - KX=1 - KY=1 - IF(INCX .LT. 0) KX=1+(1-N)*INCX - IF(INCY .LT. 0) KY=1+(1-N)*INCY -C - IF(SFLAG)120,80,100 - 80 CONTINUE - SH12=SPARAM(4) - SH21=SPARAM(3) - DO 90 I=1,N - W=SX(KX) - Z=SY(KY) - SX(KX)=W+Z*SH12 - SY(KY)=W*SH21+Z - KX=KX+INCX - KY=KY+INCY - 90 CONTINUE - GO TO 140 - 100 CONTINUE - SH11=SPARAM(2) - SH22=SPARAM(5) - DO 110 I=1,N - W=SX(KX) - Z=SY(KY) - SX(KX)=W*SH11+Z - SY(KY)=-W+SH22*Z - KX=KX+INCX - KY=KY+INCY - 110 CONTINUE - GO TO 140 - 120 CONTINUE - SH11=SPARAM(2) - SH12=SPARAM(4) - SH21=SPARAM(3) - SH22=SPARAM(5) - DO 130 I=1,N - W=SX(KX) - Z=SY(KY) - SX(KX)=W*SH11+Z*SH12 - SY(KY)=W*SH21+Z*SH22 - KX=KX+INCX - KY=KY+INCY - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/reference/srotmgf.f b/reference/srotmgf.f deleted file mode 100644 index e9998ff36..000000000 --- a/reference/srotmgf.f +++ /dev/null @@ -1,166 +0,0 @@ - SUBROUTINE SROTMGF (SD1,SD2,SX1,SY1,SPARAM) -C -C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS -C THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* -C SY2)**T. -C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. -C -C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 -C -C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) -C H=( ) ( ) ( ) ( ) -C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). -C LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 -C RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE -C VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) -C -C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE -C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE -C OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. -C - DIMENSION SPARAM(5) -C - DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/ - DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/ - IF(.NOT. SD1 .LT. ZERO) GO TO 10 -C GO ZERO-H-D-AND-SX1.. - GO TO 60 - 10 CONTINUE -C CASE-SD1-NONNEGATIVE - SP2=SD2*SY1 - IF(.NOT. SP2 .EQ. ZERO) GO TO 20 - SFLAG=-TWO - GO TO 260 -C REGULAR-CASE.. - 20 CONTINUE - SP1=SD1*SX1 - SQ2=SP2*SY1 - SQ1=SP1*SX1 -C - IF(.NOT. ABS(SQ1) .GT. ABS(SQ2)) GO TO 40 - SH21=-SY1/SX1 - SH12=SP2/SP1 -C - SU=ONE-SH12*SH21 -C - IF(.NOT. SU .LE. ZERO) GO TO 30 -C GO ZERO-H-D-AND-SX1.. - GO TO 60 - 30 CONTINUE - SFLAG=ZERO - SD1=SD1/SU - SD2=SD2/SU - SX1=SX1*SU -C GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF(.NOT. SQ2 .LT. ZERO) GO TO 50 -C GO ZERO-H-D-AND-SX1.. - GO TO 60 - 50 CONTINUE - SFLAG=ONE - SH11=SP1/SP2 - SH22=SX1/SY1 - SU=ONE+SH11*SH22 - STEMP=SD2/SU - SD2=SD1/SU - SD1=STEMP - SX1=SY1*SU -C GO SCALE-CHECK - GO TO 100 -C PROCEDURE..ZERO-H-D-AND-SX1.. - 60 CONTINUE - SFLAG=-ONE - SH11=ZERO - SH12=ZERO - SH21=ZERO - SH22=ZERO -C - SD1=ZERO - SD2=ZERO - SX1=ZERO -C RETURN.. - GO TO 220 -C PROCEDURE..FIX-H.. - 70 CONTINUE - IF(.NOT. SFLAG .GE. ZERO) GO TO 90 -C - IF(.NOT. SFLAG .EQ. ZERO) GO TO 80 - SH11=ONE - SH22=ONE - SFLAG=-ONE - GO TO 90 - 80 CONTINUE - SH21=-ONE - SH12=ONE - SFLAG=-ONE - 90 CONTINUE - GO TO IGO,(120,150,180,210) -C PROCEDURE..SCALE-CHECK - 100 CONTINUE - 110 CONTINUE - IF(.NOT. SD1 .LE. RGAMSQ) GO TO 130 - IF(SD1 .EQ. ZERO) GO TO 160 - ASSIGN 120 TO IGO -C FIX-H.. - GO TO 70 - 120 CONTINUE - SD1=SD1*GAM**2 - SX1=SX1/GAM - SH11=SH11/GAM - SH12=SH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF(.NOT. SD1 .GE. GAMSQ) GO TO 160 - ASSIGN 150 TO IGO -C FIX-H.. - GO TO 70 - 150 CONTINUE - SD1=SD1/GAM**2 - SX1=SX1*GAM - SH11=SH11*GAM - SH12=SH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF(.NOT. ABS(SD2) .LE. RGAMSQ) GO TO 190 - IF(SD2 .EQ. ZERO) GO TO 220 - ASSIGN 180 TO IGO -C FIX-H.. - GO TO 70 - 180 CONTINUE - SD2=SD2*GAM**2 - SH21=SH21/GAM - SH22=SH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF(.NOT. ABS(SD2) .GE. GAMSQ) GO TO 220 - ASSIGN 210 TO IGO -C FIX-H.. - GO TO 70 - 210 CONTINUE - SD2=SD2/GAM**2 - SH21=SH21*GAM - SH22=SH22*GAM - GO TO 200 - 220 CONTINUE - IF(SFLAG)250,230,240 - 230 CONTINUE - SPARAM(3)=SH21 - SPARAM(4)=SH12 - GO TO 260 - 240 CONTINUE - SPARAM(2)=SH11 - SPARAM(5)=SH22 - GO TO 260 - 250 CONTINUE - SPARAM(2)=SH11 - SPARAM(3)=SH21 - SPARAM(4)=SH12 - SPARAM(5)=SH22 - 260 CONTINUE - SPARAM(1)=SFLAG - RETURN - END diff --git a/reference/ssbmvf.f b/reference/ssbmvf.f deleted file mode 100644 index d1d7a67a0..000000000 --- a/reference/ssbmvf.f +++ /dev/null @@ -1,303 +0,0 @@ - SUBROUTINE SSBMVF( UPLO, N, K, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SSBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric band matrix, with k super-diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the band matrix A is being supplied as -* follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* being supplied. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* being supplied. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of super-diagonals of the -* matrix A. K must satisfy 0 .le. K. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - REAL array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - REAL array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( K.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array A -* are accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( 1, J ) - L = 1 - J - DO 90, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) - L = 1 - J - IX = JX - IY = JY - DO 110, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSBMV . -* - END diff --git a/reference/sscalf.f b/reference/sscalf.f deleted file mode 100644 index 73571bca7..000000000 --- a/reference/sscalf.f +++ /dev/null @@ -1,43 +0,0 @@ - subroutine sscalf(n,sa,sx,incx) -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to 1. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sa,sx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - sx(i) = sa*sx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - sx(i) = sa*sx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - sx(i) = sa*sx(i) - sx(i + 1) = sa*sx(i + 1) - sx(i + 2) = sa*sx(i + 2) - sx(i + 3) = sa*sx(i + 3) - sx(i + 4) = sa*sx(i + 4) - 50 continue - return - end diff --git a/reference/sspmvf.f b/reference/sspmvf.f deleted file mode 100644 index 70740ae44..000000000 --- a/reference/sspmvf.f +++ /dev/null @@ -1,262 +0,0 @@ - SUBROUTINE SSPMVF( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SSPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - REAL array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*AP( KK ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*AP( KK ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSPMV . -* - END diff --git a/reference/sspr2f.f b/reference/sspr2f.f deleted file mode 100644 index fd9b0e482..000000000 --- a/reference/sspr2f.f +++ /dev/null @@ -1,229 +0,0 @@ - SUBROUTINE SSPR2F( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SSPR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - REAL array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSPR2 . -* - END diff --git a/reference/ssprf.f b/reference/ssprf.f deleted file mode 100644 index cdf352b23..000000000 --- a/reference/ssprf.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE SSPRF ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* SSPR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - REAL array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSPR . -* - END diff --git a/reference/sswapf.f b/reference/sswapf.f deleted file mode 100644 index d7368960d..000000000 --- a/reference/sswapf.f +++ /dev/null @@ -1,56 +0,0 @@ - subroutine sswapf (n,sx,incx,sy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal to 1. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),sy(*),stemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - stemp = sx(ix) - sx(ix) = sy(iy) - sy(iy) = stemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - stemp = sx(i) - sx(i) = sy(i) - sy(i) = stemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,3 - stemp = sx(i) - sx(i) = sy(i) - sy(i) = stemp - stemp = sx(i + 1) - sx(i + 1) = sy(i + 1) - sy(i + 1) = stemp - stemp = sx(i + 2) - sx(i + 2) = sy(i + 2) - sy(i + 2) = stemp - 50 continue - return - end diff --git a/reference/ssymmf.f b/reference/ssymmf.f deleted file mode 100644 index 5b08824ed..000000000 --- a/reference/ssymmf.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE SSYMMF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - REAL ALPHA, BETA -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* SSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the symmetric matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the symmetric matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* symmetric matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* symmetric matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - REAL array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - REAL array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - REAL TEMP1, TEMP2 -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of SSYMM . -* - END diff --git a/reference/ssymvf.f b/reference/ssymvf.f deleted file mode 100644 index c1ebc3586..000000000 --- a/reference/ssymvf.f +++ /dev/null @@ -1,262 +0,0 @@ - SUBROUTINE SSYMVF ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - REAL ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SSYMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSYMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( J, J ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSYMV . -* - END diff --git a/reference/ssyr2f.f b/reference/ssyr2f.f deleted file mode 100644 index bd962e1c4..000000000 --- a/reference/ssyr2f.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE SSYR2F ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* SSYR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSYR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSYR2 . -* - END diff --git a/reference/ssyr2kf.f b/reference/ssyr2kf.f deleted file mode 100644 index bc214ca4a..000000000 --- a/reference/ssyr2kf.f +++ /dev/null @@ -1,327 +0,0 @@ - SUBROUTINE SSYR2KF( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - REAL ALPHA, BETA -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* SSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -* beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - REAL array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - REAL array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - REAL TEMP1, TEMP2 -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSYR2K. -* - END diff --git a/reference/ssyrf.f b/reference/ssyrf.f deleted file mode 100644 index 9877f563c..000000000 --- a/reference/ssyrf.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE SSYRF ( UPLO, N, ALPHA, X, INCX, A, LDA ) -* .. Scalar Arguments .. - REAL ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - REAL A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* SSYR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSYR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSYR . -* - END diff --git a/reference/ssyrkf.f b/reference/ssyrkf.f deleted file mode 100644 index 26b250981..000000000 --- a/reference/ssyrkf.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE SSYRKF ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - REAL ALPHA, BETA -* .. Array Arguments .. - REAL A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* SSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - REAL . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - REAL array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - REAL TEMP -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'SSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of SSYRK . -* - END diff --git a/reference/stbmvf.f b/reference/stbmvf.f deleted file mode 100644 index 353e63ee8..000000000 --- a/reference/stbmvf.f +++ /dev/null @@ -1,342 +0,0 @@ - SUBROUTINE STBMVF( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - REAL A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* STBMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular band matrix, with ( k + 1 ) diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'STBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = KPLUS1 - J - DO 10, I = MAX( 1, J - K ), J - 1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( KPLUS1, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 30, I = MAX( 1, J - K ), J - 1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( KPLUS1, J ) - END IF - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = 1 - J - DO 50, I = MIN( N, J + K ), J + 1, -1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( 1, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 70, I = MIN( N, J + K ), J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( 1, J ) - END IF - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - L = KPLUS1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 90, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - KX = KX - INCX - IX = KX - L = KPLUS1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 110, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX - INCX - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - L = 1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 130, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - KX = KX + INCX - IX = KX - L = 1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 150, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX + INCX - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of STBMV . -* - END diff --git a/reference/stbsvf.f b/reference/stbsvf.f deleted file mode 100644 index b0f7e46a5..000000000 --- a/reference/stbsvf.f +++ /dev/null @@ -1,336 +0,0 @@ - SUBROUTINE STBSVF(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* .. Scalar Arguments .. - INTEGER INCX,K,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - REAL A(LDA,*),X(*) -* .. -* -* Purpose -* ======= -* -* STBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Arguments -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER (ZERO=0.0E+0) -* .. -* .. Local Scalars .. - REAL TEMP - INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX,MIN -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT. (K+1)) THEN - INFO = 7 - ELSE IF (INCX.EQ.0) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('STBSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - L = KPLUS1 - J - IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) - TEMP = X(J) - DO 10 I = J - 1,MAX(1,J-K),-1 - X(I) = X(I) - TEMP*A(L+I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 40 J = N,1,-1 - KX = KX - INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = KPLUS1 - J - IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) - TEMP = X(JX) - DO 30 I = J - 1,MAX(1,J-K),-1 - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - L = 1 - J - IF (NOUNIT) X(J) = X(J)/A(1,J) - TEMP = X(J) - DO 50 I = J + 1,MIN(N,J+K) - X(I) = X(I) - TEMP*A(L+I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - KX = KX + INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = 1 - J - IF (NOUNIT) X(JX) = X(JX)/A(1,J) - TEMP = X(JX) - DO 70 I = J + 1,MIN(N,J+K) - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A')*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 100 J = 1,N - TEMP = X(J) - L = KPLUS1 - J - DO 90 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - X(J) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120 J = 1,N - TEMP = X(JX) - IX = KX - L = KPLUS1 - J - DO 110 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX + INCX - 110 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - X(JX) = TEMP - JX = JX + INCX - IF (J.GT.K) KX = KX + INCX - 120 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 140 J = N,1,-1 - TEMP = X(J) - L = 1 - J - DO 130 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(I) - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - X(J) = TEMP - 140 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 160 J = N,1,-1 - TEMP = X(JX) - IX = KX - L = 1 - J - DO 150 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX - INCX - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - X(JX) = TEMP - JX = JX - INCX - IF ((N-J).GE.K) KX = KX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of STBSV . -* - END diff --git a/reference/stpmvf.f b/reference/stpmvf.f deleted file mode 100644 index 1e93b843a..000000000 --- a/reference/stpmvf.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE STPMVF( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - REAL AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* STPMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - REAL array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'STPMVF', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x:= A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK =1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K + 1 - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK + J - 1 ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, K = KK, KK + J - 2 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK + J - 1 ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K - 1 - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK - N + J ) - END IF - KK = KK - ( N - J + 1 ) - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK - N + J ) - END IF - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - K = KK - 1 - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + AP( K )*X( I ) - K = K - 1 - 90 CONTINUE - X( J ) = TEMP - KK = KK - J - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 110, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + AP( K )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - KK = KK - J - 120 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - K = KK + 1 - DO 130, I = J + 1, N - TEMP = TEMP + AP( K )*X( I ) - K = K + 1 - 130 CONTINUE - X( J ) = TEMP - KK = KK + ( N - J + 1 ) - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 150, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + AP( K )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of STPMV . -* - END diff --git a/reference/stpsvf.f b/reference/stpsvf.f deleted file mode 100644 index 9fa2f59e9..000000000 --- a/reference/stpsvf.f +++ /dev/null @@ -1,302 +0,0 @@ - SUBROUTINE STPSVF( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - REAL AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* STPSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix, supplied in packed form. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - REAL array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'STPSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK - 1 - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*AP( K ) - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 30, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK + 1 - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*AP( K ) - K = K + 1 - 50 CONTINUE - END IF - KK = KK + ( N - J + 1 ) - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - K = KK - DO 90, I = 1, J - 1 - TEMP = TEMP - AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - X( J ) = TEMP - KK = KK + J - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, K = KK, KK + J - 2 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - X( JX ) = TEMP - JX = JX + INCX - KK = KK + J - 120 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - K = KK - DO 130, I = N, J + 1, -1 - TEMP = TEMP - AP( K )*X( I ) - K = K - 1 - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - X( J ) = TEMP - KK = KK - ( N - J + 1 ) - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - X( JX ) = TEMP - JX = JX - INCX - KK = KK - (N - J + 1 ) - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of STPSV . -* - END diff --git a/reference/strmmf.f b/reference/strmmf.f deleted file mode 100644 index 04ea865ac..000000000 --- a/reference/strmmf.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE STRMMF ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - REAL ALPHA -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* STRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ), -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - REAL array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - REAL TEMP -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'STRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B. -* - IF( UPPER )THEN - DO 110, J = 1, N - DO 100, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - B( I, J ) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 120, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 120 CONTINUE - B( I, J ) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 180, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 150 CONTINUE - DO 170, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 160, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 190, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 190 CONTINUE - DO 210, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 200, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A'. -* - IF( UPPER )THEN - DO 260, K = 1, N - DO 240, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 230, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 250, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300, K = N, 1, -1 - DO 280, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 270, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of STRMM . -* - END diff --git a/reference/strmvf.f b/reference/strmvf.f deleted file mode 100644 index 249aff275..000000000 --- a/reference/strmvf.f +++ /dev/null @@ -1,286 +0,0 @@ - SUBROUTINE STRMVF ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - REAL A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* STRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'STRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 110, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 130, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of STRMV . -* - END diff --git a/reference/strsmf.f b/reference/strsmf.f deleted file mode 100644 index 31d71a785..000000000 --- a/reference/strsmf.f +++ /dev/null @@ -1,378 +0,0 @@ - SUBROUTINE STRSMF ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - REAL ALPHA -* .. Array Arguments .. - REAL A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* STRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - REAL . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - REAL array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - REAL TEMP -* .. Parameters .. - REAL ONE , ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'STRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of STRSM . -* - END diff --git a/reference/strsvf.f b/reference/strsvf.f deleted file mode 100644 index dcf020f30..000000000 --- a/reference/strsvf.f +++ /dev/null @@ -1,289 +0,0 @@ - SUBROUTINE STRSVF ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - REAL A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* STRSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - REAL array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - REAL array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - REAL ZERO - PARAMETER ( ZERO = 0.0E+0 ) -* .. Local Scalars .. - REAL TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'STRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX + INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - DO 130, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of STRSV . -* - END diff --git a/reference/strti2f.f b/reference/strti2f.f deleted file mode 100644 index b859cff3b..000000000 --- a/reference/strti2f.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE STRTI2F( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* STRTI2 computes the inverse of a real upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - REAL AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL SSCAL, STRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'STRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL STRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL SSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL STRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL SSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of STRTI2 -* - END diff --git a/reference/strtrif.f b/reference/strtrif.f deleted file mode 100644 index 39919e9c5..000000000 --- a/reference/strtrif.f +++ /dev/null @@ -1,176 +0,0 @@ - SUBROUTINE STRTRIF( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - REAL A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* STRTRI computes the inverse of a real upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) REAL array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - REAL ONE, ZERO - PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL STRMM, STRSM, STRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'STRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = 128 - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL STRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL STRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL STRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL STRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL STRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL STRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL STRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of STRTRI -* - END diff --git a/reference/zaxpycf.f b/reference/zaxpycf.f deleted file mode 100644 index aaf21da9f..000000000 --- a/reference/zaxpycf.f +++ /dev/null @@ -1,36 +0,0 @@ - subroutine zaxpycf(n,za,zx,incx,zy,incy) -c -c constant times a vector plus a vector. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),za - integer i,incx,incy,ix,iy,n - double precision dcabs1 - INTRINSIC dconjg - - if(n.le.0)return - if (dcabs1(za) .eq. 0.0d0) return - if (incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - zy(iy) = zy(iy) + za*dconjg(zx(ix)) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - zy(i) = zy(i) + za*dconjg(zx(i)) - 30 continue - return - end diff --git a/reference/zaxpyf.f b/reference/zaxpyf.f deleted file mode 100644 index 2f0f6a077..000000000 --- a/reference/zaxpyf.f +++ /dev/null @@ -1,34 +0,0 @@ - subroutine zaxpyf(n,za,zx,incx,zy,incy) -c -c constant times a vector plus a vector. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),za - integer i,incx,incy,ix,iy,n - double precision dcabs1 - if(n.le.0)return - if (dcabs1(za) .eq. 0.0d0) return - if (incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - zy(iy) = zy(iy) + za*zx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - zy(i) = zy(i) + za*zx(i) - 30 continue - return - end diff --git a/reference/zcopyf.f b/reference/zcopyf.f deleted file mode 100644 index a3bfdfc98..000000000 --- a/reference/zcopyf.f +++ /dev/null @@ -1,33 +0,0 @@ - subroutine zcopyf(n,zx,incx,zy,incy) -c -c copies a vector, x, to a vector, y. -c jack dongarra, linpack, 4/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*) - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - zy(iy) = zx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - zy(i) = zx(i) - 30 continue - return - end diff --git a/reference/zdotcf.f b/reference/zdotcf.f deleted file mode 100644 index 1611aee8c..000000000 --- a/reference/zdotcf.f +++ /dev/null @@ -1,36 +0,0 @@ - double complex function zdotcf(n,zx,incx,zy,incy) -c -c forms the dot product of a vector. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),ztemp - integer i,incx,incy,ix,iy,n - ztemp = (0.0d0,0.0d0) - zdotcf = (0.0d0,0.0d0) - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = ztemp + dconjg(zx(ix))*zy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - zdotcf = ztemp - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ztemp = ztemp + dconjg(zx(i))*zy(i) - 30 continue - zdotcf = ztemp - return - end diff --git a/reference/zdotuf.f b/reference/zdotuf.f deleted file mode 100644 index cc2ea939f..000000000 --- a/reference/zdotuf.f +++ /dev/null @@ -1,36 +0,0 @@ - double complex function zdotuf(n,zx,incx,zy,incy) -c -c forms the dot product of two vectors. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),ztemp - integer i,incx,incy,ix,iy,n - ztemp = (0.0d0,0.0d0) - zdotuf = (0.0d0,0.0d0) - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = ztemp + zx(ix)*zy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - zdotuf = ztemp - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ztemp = ztemp + zx(i)*zy(i) - 30 continue - zdotuf = ztemp - return - end diff --git a/reference/zdrotf.f b/reference/zdrotf.f deleted file mode 100644 index fe11288c4..000000000 --- a/reference/zdrotf.f +++ /dev/null @@ -1,38 +0,0 @@ - subroutine zdrotf (n,zx,incx,zy,incy,c,s) -c -c applies a plane rotation, where the cos and sin (c and s) are -c double precision and the vectors zx and zy are double complex. -c jack dongarra, linpack, 3/11/78. -c - double complex zx(1),zy(1),ztemp - double precision c,s - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = c*zx(ix) + s*zy(iy) - zy(iy) = c*zy(iy) - s*zx(ix) - zx(ix) = ztemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - ztemp = c*zx(i) + s*zy(i) - zy(i) = c*zy(i) - s*zx(i) - zx(i) = ztemp - 30 continue - return - end diff --git a/reference/zdscalf.f b/reference/zdscalf.f deleted file mode 100644 index 0ac1534b6..000000000 --- a/reference/zdscalf.f +++ /dev/null @@ -1,30 +0,0 @@ - subroutine zdscalf(n,da,zx,incx) -c -c scales a vector by a constant. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision da - integer i,incx,ix,n -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - zx(ix) = dcmplx(da,0.0d0)*zx(ix) - ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - zx(i) = dcmplx(da,0.0d0)*zx(i) - 30 continue - return - end diff --git a/reference/zgbmvf.f b/reference/zgbmvf.f deleted file mode 100644 index bd888b16f..000000000 --- a/reference/zgbmvf.f +++ /dev/null @@ -1,450 +0,0 @@ - SUBROUTINE ZGBMVF( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGBMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -* -* y := alpha*conjg( A' )*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n band matrix, with kl sub-diagonals and ku super-diagonals. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* KL - INTEGER. -* On entry, KL specifies the number of sub-diagonals of the -* matrix A. KL must satisfy 0 .le. KL. -* Unchanged on exit. -* -* KU - INTEGER. -* On entry, KU specifies the number of super-diagonals of the -* matrix A. KU must satisfy 0 .le. KU. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading ( kl + ku + 1 ) by n part of the -* array A must contain the matrix of coefficients, supplied -* column by column, with the leading diagonal of the matrix in -* row ( ku + 1 ) of the array, the first super-diagonal -* starting at position 2 in row ku, the first sub-diagonal -* starting at position 1 in row ( ku + 2 ), and so on. -* Elements in the array A that do not correspond to elements -* in the band matrix (such as the top left ku by ku triangle) -* are not referenced. -* The following program segment will transfer a band matrix -* from conventional full matrix storage to band storage: -* -* DO 20, J = 1, N -* K = KU + 1 - J -* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -* A( K + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( kl + ku + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY - LOGICAL NOCONJ, NOTRANS, XCONJ -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ).AND. - $ .NOT.LSAME( TRANS, 'O' ).AND. - $ .NOT.LSAME( TRANS, 'U' ).AND. - $ .NOT.LSAME( TRANS, 'S' ).AND. - $ .NOT.LSAME( TRANS, 'D' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( KL.LT.0 )THEN - INFO = 4 - ELSE IF( KU.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN - INFO = 8 - ELSE IF( INCX.EQ.0 )THEN - INFO = 10 - ELSE IF( INCY.EQ.0 )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* - NOCONJ = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - $ .OR. LSAME( TRANS, 'O' ) .OR. LSAME( TRANS, 'U' )) - - NOTRANS = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'R' ) - $ .OR. LSAME( TRANS, 'O' ) .OR. LSAME( TRANS, 'S' )) - - XCONJ = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - $ .OR. LSAME( TRANS, 'R' ) .OR. LSAME( TRANS, 'C' )) -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF(NOTRANS)THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the band part of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - - KUP1 = KU + 1 - - IF(XCONJ)THEN - - IF(NOTRANS)THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - K = KUP1 - J - IF( NOCONJ )THEN - DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 50 CONTINUE - ELSE - DO 55, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*DCONJG(A( K + I, J )) - 55 CONTINUE - END IF - - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - K = KUP1 - J - IF( NOCONJ )THEN - DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 70 CONTINUE - ELSE - DO 75, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*DCONJG(A( K + I, J )) - IY = IY + INCY - 75 CONTINUE - END IF - - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - K = KUP1 - J - IF( NOCONJ )THEN - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - ELSE - DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + DCONJG( A( K + I, J ) )*X( I ) - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - IF( NOCONJ )THEN - DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + DCONJG( A( K + I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 140 CONTINUE - END IF - END IF - - ELSE - - IF(NOTRANS)THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 160, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG(X( JX )) - K = KUP1 - J - IF( NOCONJ )THEN - DO 150, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 150 CONTINUE - ELSE - DO 155, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*DCONJG(A( K + I, J )) - 155 CONTINUE - END IF - - END IF - JX = JX + INCX - 160 CONTINUE - ELSE - DO 180, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG(X( JX )) - IY = KY - K = KUP1 - J - IF( NOCONJ )THEN - DO 170, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 170 CONTINUE - ELSE - DO 175, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*DCONJG(A( K + I, J )) - IY = IY + INCY - 175 CONTINUE - END IF - - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 180 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 210, J = 1, N - TEMP = ZERO - K = KUP1 - J - IF( NOCONJ )THEN - DO 190, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*DCONJG(X( I )) - 190 CONTINUE - ELSE - DO 200, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + DCONJG( A( K + I, J ) )*DCONJG(X( I )) - 200 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 210 CONTINUE - ELSE - DO 240, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - IF( NOCONJ )THEN - DO 220, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*DCONJG(X( IX )) - IX = IX + INCX - 220 CONTINUE - ELSE - DO 230, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + DCONJG( A( K + I, J ) )*DCONJG(X(IX )) - IX = IX + INCX - 230 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 240 CONTINUE - END IF - END IF - - END IF - -* - RETURN -* -* End of ZGBMV . -* - END diff --git a/reference/zgemm3mf.f b/reference/zgemm3mf.f deleted file mode 100644 index 3bfc88bb5..000000000 --- a/reference/zgemm3mf.f +++ /dev/null @@ -1,414 +0,0 @@ - SUBROUTINE ZGEMM3MF(TRA,TRB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* .. Scalar Arguments .. - DOUBLE COMPLEX ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRA,TRB -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* Purpose -* ======= -* -* ZGEMM 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' or op( X ) = conjg( X' ), -* -* 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. -* -* Arguments -* ========== -* -* TRA - CHARACTER*1. -* On entry, TRA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRA = 'N' or 'n', op( A ) = A. -* -* TRA = 'T' or 't', op( A ) = A'. -* -* TRA = 'C' or 'c', op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* TRB - CHARACTER*1. -* On entry, TRB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRB = 'N' or 'n', op( B ) = B. -* -* TRB = 'T' or 't', op( B ) = B'. -* -* TRB = 'C' or 'c', op( B ) = conjg( B' ). -* -* Unchanged on exit. -* -* M - 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. -* Unchanged on exit. -* -* N - 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. -* Unchanged on exit. -* -* K - 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. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRA = 'N' or 'n', and is m otherwise. -* Before entry with TRA = '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. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* n when TRB = 'N' or 'n', and is k otherwise. -* Before entry with TRB = '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. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of 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 ). -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL CONJA,CONJB,NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE COMPLEX ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - DOUBLE COMPLEX ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* conjugated or transposed, set CONJA and CONJB as true if A and -* B respectively are to be transposed but not conjugated 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(TRA,'N') - NOTB = LSAME(TRB,'N') - CONJA = LSAME(TRA,'C') - CONJB = LSAME(TRB,'C') - 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.CONJA) .AND. - + (.NOT.LSAME(TRA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. - + (.NOT.LSAME(TRB,'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('ZGEMM ',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 when 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 - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE IF (CONJA) THEN -* -* Form C := alpha*conjg( A' )*B + beta*C. -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + DCONJG(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 - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 150 J = 1,N - DO 140 I = 1,M - TEMP = ZERO - DO 130 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 130 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF (NOTA) THEN - IF (CONJB) THEN -* -* Form C := alpha*A*conjg( B' ) + beta*C. -* - DO 200 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 160 I = 1,M - C(I,J) = ZERO - 160 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 170 I = 1,M - C(I,J) = BETA*C(I,J) - 170 CONTINUE - END IF - DO 190 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(B(J,L)) - DO 180 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE -* -* Form C := alpha*A*B' + beta*C -* - DO 250 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 210 I = 1,M - C(I,J) = ZERO - 210 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 220 I = 1,M - C(I,J) = BETA*C(I,J) - 220 CONTINUE - END IF - DO 240 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 230 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 230 CONTINUE - END IF - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF (CONJA) THEN - IF (CONJB) THEN -* -* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. -* - DO 280 J = 1,N - DO 270 I = 1,M - TEMP = ZERO - DO 260 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) - 260 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -* -* Form C := alpha*conjg( A' )*B' + beta*C -* - DO 310 J = 1,N - DO 300 I = 1,M - TEMP = ZERO - DO 290 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*B(J,L) - 290 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF (CONJB) THEN -* -* Form C := alpha*A'*conjg( B' ) + beta*C -* - DO 340 J = 1,N - DO 330 I = 1,M - TEMP = ZERO - DO 320 L = 1,K - TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) - 320 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 370 J = 1,N - DO 360 I = 1,M - TEMP = ZERO - DO 350 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 350 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMM . -* - END diff --git a/reference/zgemmf.f b/reference/zgemmf.f deleted file mode 100644 index 65cd31750..000000000 --- a/reference/zgemmf.f +++ /dev/null @@ -1,414 +0,0 @@ - SUBROUTINE ZGEMMF(TRANA,TRANB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) -* .. Scalar Arguments .. - DOUBLE COMPLEX ALPHA,BETA - INTEGER K,LDA,LDB,LDC,M,N - CHARACTER TRANA,TRANB -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) -* .. -* -* Purpose -* ======= -* -* ZGEMM 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' or op( X ) = conjg( X' ), -* -* 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. -* -* Arguments -* ========== -* -* TRANA - CHARACTER*1. -* On entry, TRANA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANA = 'N' or 'n', op( A ) = A. -* -* TRANA = 'T' or 't', op( A ) = A'. -* -* TRANA = 'C' or 'c', op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* TRANB - CHARACTER*1. -* On entry, TRANB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANB = 'N' or 'n', op( B ) = B. -* -* TRANB = 'T' or 't', op( B ) = B'. -* -* TRANB = 'C' or 'c', op( B ) = conjg( B' ). -* -* Unchanged on exit. -* -* M - 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. -* Unchanged on exit. -* -* N - 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. -* Unchanged on exit. -* -* K - 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. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANA = 'N' or 'n', and is m otherwise. -* Before entry with TRANA = '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. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* n when TRANB = 'N' or 'n', and is k otherwise. -* Before entry with TRANB = '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. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of 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 ). -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB - LOGICAL CONJA,CONJB,NOTA,NOTB -* .. -* .. Parameters .. - DOUBLE COMPLEX ONE - PARAMETER (ONE= (1.0D+0,0.0D+0)) - DOUBLE COMPLEX ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* conjugated or transposed, set CONJA and CONJB as true if A and -* B respectively are to be transposed but not conjugated 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(TRANA,'N') - NOTB = LSAME(TRANB,'N') - CONJA = LSAME(TRANA,'C') - CONJB = LSAME(TRANB,'C') - 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.CONJA) .AND. - + (.NOT.LSAME(TRANA,'T'))) THEN - INFO = 1 - ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. - + (.NOT.LSAME(TRANB,'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('ZGEMM ',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 when 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 - IF (B(L,J).NE.ZERO) THEN - TEMP = ALPHA*B(L,J) - DO 70 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE IF (CONJA) THEN -* -* Form C := alpha*conjg( A' )*B + beta*C. -* - DO 120 J = 1,N - DO 110 I = 1,M - TEMP = ZERO - DO 100 L = 1,K - TEMP = TEMP + DCONJG(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 - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 150 J = 1,N - DO 140 I = 1,M - TEMP = ZERO - DO 130 L = 1,K - TEMP = TEMP + A(L,I)*B(L,J) - 130 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 140 CONTINUE - 150 CONTINUE - END IF - ELSE IF (NOTA) THEN - IF (CONJB) THEN -* -* Form C := alpha*A*conjg( B' ) + beta*C. -* - DO 200 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 160 I = 1,M - C(I,J) = ZERO - 160 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 170 I = 1,M - C(I,J) = BETA*C(I,J) - 170 CONTINUE - END IF - DO 190 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*DCONJG(B(J,L)) - DO 180 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE -* -* Form C := alpha*A*B' + beta*C -* - DO 250 J = 1,N - IF (BETA.EQ.ZERO) THEN - DO 210 I = 1,M - C(I,J) = ZERO - 210 CONTINUE - ELSE IF (BETA.NE.ONE) THEN - DO 220 I = 1,M - C(I,J) = BETA*C(I,J) - 220 CONTINUE - END IF - DO 240 L = 1,K - IF (B(J,L).NE.ZERO) THEN - TEMP = ALPHA*B(J,L) - DO 230 I = 1,M - C(I,J) = C(I,J) + TEMP*A(I,L) - 230 CONTINUE - END IF - 240 CONTINUE - 250 CONTINUE - END IF - ELSE IF (CONJA) THEN - IF (CONJB) THEN -* -* Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. -* - DO 280 J = 1,N - DO 270 I = 1,M - TEMP = ZERO - DO 260 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) - 260 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 270 CONTINUE - 280 CONTINUE - ELSE -* -* Form C := alpha*conjg( A' )*B' + beta*C -* - DO 310 J = 1,N - DO 300 I = 1,M - TEMP = ZERO - DO 290 L = 1,K - TEMP = TEMP + DCONJG(A(L,I))*B(J,L) - 290 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 300 CONTINUE - 310 CONTINUE - END IF - ELSE - IF (CONJB) THEN -* -* Form C := alpha*A'*conjg( B' ) + beta*C -* - DO 340 J = 1,N - DO 330 I = 1,M - TEMP = ZERO - DO 320 L = 1,K - TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) - 320 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 330 CONTINUE - 340 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 370 J = 1,N - DO 360 I = 1,M - TEMP = ZERO - DO 350 L = 1,K - TEMP = TEMP + A(L,I)*B(J,L) - 350 CONTINUE - IF (BETA.EQ.ZERO) THEN - C(I,J) = ALPHA*TEMP - ELSE - C(I,J) = ALPHA*TEMP + BETA*C(I,J) - END IF - 360 CONTINUE - 370 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZGEMM . -* - END diff --git a/reference/zgemvf.f b/reference/zgemvf.f deleted file mode 100644 index 10d2d7413..000000000 --- a/reference/zgemvf.f +++ /dev/null @@ -1,332 +0,0 @@ - SUBROUTINE ZGEMVF ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE COMPLEX ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE COMPLEX A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* CGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or -* -* y := alpha*conjg( A' )*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - COMPLEX array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) - DOUBLE COMPLEX ZERO - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY - LOGICAL NOCONJ, NOTRANS, XCONJ -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ).AND. - $ .NOT.LSAME( TRANS, 'O' ).AND. - $ .NOT.LSAME( TRANS, 'U' ).AND. - $ .NOT.LSAME( TRANS, 'S' ).AND. - $ .NOT.LSAME( TRANS, 'D' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'CGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* - NOCONJ = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - $ .OR. LSAME( TRANS, 'O' ) .OR. LSAME( TRANS, 'U' )) - - NOTRANS = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'R' ) - $ .OR. LSAME( TRANS, 'O' ) .OR. LSAME( TRANS, 'S' )) - - XCONJ = (LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - $ .OR. LSAME( TRANS, 'R' ) .OR. LSAME( TRANS, 'C' )) -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF(NOTRANS)THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - - IF(NOTRANS)THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF (XCONJ) THEN - TEMP = ALPHA*X( JX ) - ELSE - TEMP = ALPHA*DCONJG(X( JX )) - ENDIF - IF (NOCONJ) THEN - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - ELSE - DO 55, I = 1, M - Y( I ) = Y( I ) + TEMP*DCONJG(A( I, J )) - 55 CONTINUE - ENDIF - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF (XCONJ) THEN - TEMP = ALPHA*X( JX ) - ELSE - TEMP = ALPHA*DCONJG(X( JX )) - ENDIF - IY = KY - IF (NOCONJ) THEN - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - ELSE - DO 75, I = 1, M - Y( IY ) = Y( IY ) + TEMP* DCONJG(A( I, J )) - IY = IY + INCY - 75 CONTINUE - ENDIF - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = ZERO - IF( NOCONJ )THEN - DO 90, I = 1, M - IF (XCONJ) THEN - TEMP = TEMP + A( I, J )*X( I ) - ELSE - TEMP = TEMP + A( I, J )*DCONJG(X( I )) - ENDIF - 90 CONTINUE - ELSE - DO 100, I = 1, M - IF (XCONJ) THEN - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - ELSE - TEMP = TEMP + DCONJG( A( I, J ) )*DCONJG(X( I )) - ENDIF - 100 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 110 CONTINUE - ELSE - DO 140, J = 1, N - TEMP = ZERO - IX = KX - IF( NOCONJ )THEN - DO 120, I = 1, M - IF (XCONJ) THEN - TEMP = TEMP + A( I, J )*X( IX ) - ELSE - TEMP = TEMP + A( I, J )*DCONJG(X( IX )) - ENDIF - IX = IX + INCX - 120 CONTINUE - ELSE - DO 130, I = 1, M - IF (XCONJ) THEN - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - ELSE - TEMP = TEMP + DCONJG( A( I, J ) )*DCONJG(X( IX )) - ENDIF - IX = IX + INCX - 130 CONTINUE - END IF - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 140 CONTINUE - END IF - END IF -* - RETURN -* -* End of CGEMV . -* - END - diff --git a/reference/zgercf.f b/reference/zgercf.f deleted file mode 100644 index 47f8a9307..000000000 --- a/reference/zgercf.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE ZGERCF ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGERC performs the rank 1 operation -* -* A := alpha*x*conjg( y' ) + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGERC ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( Y( JY ) ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( Y( JY ) ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of ZGERC . -* - END diff --git a/reference/zgeruf.f b/reference/zgeruf.f deleted file mode 100644 index 619f778cc..000000000 --- a/reference/zgeruf.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE ZGERUF ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZGERU performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZGERU ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of ZGERU . -* - END diff --git a/reference/zgesvf.f b/reference/zgesvf.f deleted file mode 100644 index d341dd790..000000000 --- a/reference/zgesvf.f +++ /dev/null @@ -1,107 +0,0 @@ - SUBROUTINE ZGESVF( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZGESV computes the solution to a complex system of linear equations -* A * X = B, -* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as -* A = P * L * U, -* where P is a permutation matrix, L is unit lower triangular, and U is -* upper triangular. The factored form of A is then used to solve the -* system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the N-by-N coefficient matrix A. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS matrix of right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, so the solution could not be computed. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL XERBLA, ZGETRF, ZGETRS -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL ZGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of ZGESV -* - END diff --git a/reference/zgetf2f.f b/reference/zgetf2f.f deleted file mode 100644 index 6b8bc3952..000000000 --- a/reference/zgetf2f.f +++ /dev/null @@ -1,136 +0,0 @@ - SUBROUTINE ZGETF2F( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER IZAMAX - EXTERNAL IZAMAX -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), - $ LDA, A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of ZGETF2 -* - END diff --git a/reference/zgetrff.f b/reference/zgetrff.f deleted file mode 100644 index bfb438d69..000000000 --- a/reference/zgetrff.f +++ /dev/null @@ -1,156 +0,0 @@ - SUBROUTINE ZGETRFF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 64 - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL ZGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of ZGETRF -* - END diff --git a/reference/zgetrsf.f b/reference/zgetrsf.f deleted file mode 100644 index 823798b52..000000000 --- a/reference/zgetrsf.f +++ /dev/null @@ -1,150 +0,0 @@ - SUBROUTINE ZGETRSF( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZGETRS solves a system of linear equations -* A * X = B, A**T * X = B, or A**H * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by ZGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T * X = B (Transpose) -* = 'C': A**H * X = B (Conjugate transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) COMPLEX*16 array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by ZGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from ZGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLASWP, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) .OR. LSAME(TRANS, 'R') - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A**T * X = B or A**H * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A, - $ LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of ZGETRS -* - END diff --git a/reference/zhbmvf.f b/reference/zhbmvf.f deleted file mode 100644 index 875c3e034..000000000 --- a/reference/zhbmvf.f +++ /dev/null @@ -1,406 +0,0 @@ - SUBROUTINE ZHBMVF( UPLO, N, K, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian band matrix, with k super-diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the band matrix A is being supplied as -* follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* being supplied. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* being supplied. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of super-diagonals of the -* matrix A. K must satisfy 0 .le. K. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the hermitian matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a hermitian band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the hermitian matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a hermitian band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ).AND. - $ .NOT.LSAME( UPLO, 'V' ).AND. - $ .NOT.LSAME( UPLO, 'M' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( K.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array A -* are accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - - -* -* Form y when upper triangle of A is stored. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( A( KPLUS1, J ) ) - $ + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( KPLUS1, J ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - RETURN - ENDIF - -* -* Form y when lower triangle of A is stored. -* - IF( LSAME( UPLO, 'L' ) )THEN - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( A( 1, J ) ) - L = 1 - J - DO 90, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( 1, J ) ) - L = 1 - J - IX = JX - IY = JY - DO 110, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + DCONJG( A( L + I, J ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - RETURN - END IF - - -* -* Form y when upper triangle of A is stored. -* - IF( LSAME( UPLO, 'V' ) )THEN - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 160, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 150, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*DCONJG(A( L + I, J )) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 150 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( A( KPLUS1, J ) ) - $ + ALPHA*TEMP2 - 160 CONTINUE - ELSE - JX = KX - JY = KY - DO 180, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 170, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*DCONJG(A( L + I, J )) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 170 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( KPLUS1, J ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 180 CONTINUE - END IF - RETURN - ENDIF - -* -* Form y when lower triangle of A is stored. -* - IF( LSAME( UPLO, 'M' ) )THEN - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 200, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( A( 1, J ) ) - L = 1 - J - DO 190, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*DCONJG(A( L + I, J )) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 190 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 200 CONTINUE - ELSE - JX = KX - JY = KY - DO 220, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( 1, J ) ) - L = 1 - J - IX = JX - IY = JY - DO 210, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*DCONJG(A( L + I, J )) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - 210 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 220 CONTINUE - END IF - RETURN - END IF - - - -* - RETURN -* -* End of ZHBMV . -* - END diff --git a/reference/zhemm3mf.f b/reference/zhemm3mf.f deleted file mode 100644 index 2247e2cb3..000000000 --- a/reference/zhemm3mf.f +++ /dev/null @@ -1,304 +0,0 @@ - SUBROUTINE ZHEMM3MF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHEMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is an hermitian matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the hermitian matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the hermitian matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* hermitian matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* hermitian matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHEMM3M', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*DCONJG( A( K, I ) ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*DCONJG( A( K, I ) ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*DBLE( A( J, J ) ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*DCONJG( A( J, K ) ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of ZHEMM . -* - END diff --git a/reference/zhemmf.f b/reference/zhemmf.f deleted file mode 100644 index dbe8fb188..000000000 --- a/reference/zhemmf.f +++ /dev/null @@ -1,304 +0,0 @@ - SUBROUTINE ZHEMMF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHEMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is an hermitian matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the hermitian matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the hermitian matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* hermitian matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* hermitian matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the hermitian matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the hermitian matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the hermitian -* matrix and the strictly upper triangular part of A is not -* referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHEMM3M', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*DCONJG( A( K, I ) ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1*A( K, I ) - TEMP2 = TEMP2 + - $ B( K, J )*DCONJG( A( K, I ) ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*DBLE( A( I, I ) ) + - $ ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*DBLE( A( J, J ) ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*DCONJG( A( J, K ) ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of ZHEMM . -* - END diff --git a/reference/zhemvf.f b/reference/zhemvf.f deleted file mode 100644 index ac8a04f1f..000000000 --- a/reference/zhemvf.f +++ /dev/null @@ -1,351 +0,0 @@ - SUBROUTINE ZHEMVF ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHEMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ).AND. - $ .NOT.LSAME( UPLO, 'V' ).AND. - $ .NOT.LSAME( UPLO, 'M' ))THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - - - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - RETURN - ENDIF - - - IF( LSAME( UPLO, 'L' ) )THEN -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + DCONJG( A( I, J ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - RETURN - END IF - - - IF( LSAME( UPLO, 'V' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 160, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 150, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1* DCONJG(A( I, J )) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 150 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 - 160 CONTINUE - ELSE - JX = KX - JY = KY - DO 180, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 170, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1* DCONJG(A( I, J )) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 170 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 180 CONTINUE - END IF - RETURN - ENDIF - - - IF( LSAME( UPLO, 'M' ) )THEN -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 200, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( A( J, J ) ) - DO 190, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*DCONJG(A( I, J )) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 190 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 200 CONTINUE - ELSE - JX = KX - JY = KY - DO 220, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( A( J, J ) ) - IX = JX - IY = JY - DO 210, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*DCONJG(A( I, J )) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 210 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 220 CONTINUE - END IF - RETURN - END IF -* - RETURN -* -* End of ZHEMV . -* - END diff --git a/reference/zher2f.f b/reference/zher2f.f deleted file mode 100644 index 4ae3e4ce3..000000000 --- a/reference/zher2f.f +++ /dev/null @@ -1,249 +0,0 @@ - SUBROUTINE ZHER2F ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHER2 performs the hermitian rank 2 operation -* -* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n hermitian matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHER2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - A( J, J ) = DBLE( A( J, J ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2 . -* - END diff --git a/reference/zher2kf.f b/reference/zher2kf.f deleted file mode 100644 index 43b75d95f..000000000 --- a/reference/zher2kf.f +++ /dev/null @@ -1,372 +0,0 @@ - SUBROUTINE ZHER2KF( UPLO, TRANS, N, K, ALPHA, A, LDA, B,LDB, BETA, - $ C, LDC ) -* .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER K, LDA, LDB, LDC, N - DOUBLE PRECISION BETA - COMPLEX*16 ALPHA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHER2K performs one of the hermitian rank 2k operations -* -* C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, -* -* or -* -* C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, -* -* where alpha and beta are scalars with beta real, C is an n by n -* hermitian matrix and A and B are n by k matrices in the first case -* and k by n matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + -* conjg( alpha )*B*conjg( A' ) + -* beta*C. -* -* TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + -* conjg( alpha )*conjg( B' )*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'C' or 'c', K specifies the number of rows of the -* matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. -* Ed Anderson, Cray Research Inc. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCONJG, MAX -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) ) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN - INFO = 2 - ELSE IF( N.LT.0 ) THEN - INFO = 3 - ELSE IF( K.LT.0 ) THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) ) THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = 12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHER2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. - $ ( BETA.EQ.ONE ) ) )RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO ) THEN - IF( UPPER ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 60 J = 1, N - DO 50 I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 70 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) ) THEN -* -* Form C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + -* C. -* - IF( UPPER ) THEN - DO 130 J = 1, N - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 90 I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 100 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 120 L = 1, K - IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) - $ THEN - TEMP1 = ALPHA*DCONJG( B( J, L ) ) - TEMP2 = DCONJG( ALPHA*A( J, L ) ) - DO 110 I = 1, J - 1 - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1, N - IF( BETA.EQ.DBLE( ZERO ) ) THEN - DO 140 I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 150 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 170 L = 1, K - IF( ( A( J, L ).NE.ZERO ) .OR. ( B( J, L ).NE.ZERO ) ) - $ THEN - TEMP1 = ALPHA*DCONJG( B( J, L ) ) - TEMP2 = DCONJG( ALPHA*A( J, L ) ) - DO 160 I = J + 1, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( A( J, L )*TEMP1+B( J, L )*TEMP2 ) - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + -* C. -* - IF( UPPER ) THEN - DO 210 J = 1, N - DO 200 I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190 L = 1, K - TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) - 190 CONTINUE - IF( I.EQ.J ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - ELSE - C( J, J ) = BETA*DBLE( C( J, J ) ) + - $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + - $ DCONJG( ALPHA )*TEMP2 - END IF - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240 J = 1, N - DO 230 I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220 L = 1, K - TEMP1 = TEMP1 + DCONJG( A( L, I ) )*B( L, J ) - TEMP2 = TEMP2 + DCONJG( B( L, I ) )*A( L, J ) - 220 CONTINUE - IF( I.EQ.J ) THEN - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( J, J ) = DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - ELSE - C( J, J ) = BETA*DBLE( C( J, J ) ) + - $ DBLE( ALPHA*TEMP1+DCONJG( ALPHA )* - $ TEMP2 ) - END IF - ELSE - IF( BETA.EQ.DBLE( ZERO ) ) THEN - C( I, J ) = ALPHA*TEMP1 + DCONJG( ALPHA )*TEMP2 - ELSE - C( I, J ) = BETA*C( I, J ) + ALPHA*TEMP1 + - $ DCONJG( ALPHA )*TEMP2 - END IF - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER2K. -* - END diff --git a/reference/zherf.f b/reference/zherf.f deleted file mode 100644 index ebde22ca5..000000000 --- a/reference/zherf.f +++ /dev/null @@ -1,212 +0,0 @@ - SUBROUTINE ZHERF ( UPLO, N, ALPHA, X, INCX, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZHER performs the hermitian rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n hermitian matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - DO 10, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( J )*TEMP ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - IX = KX - DO 30, I = 1, J - 1 - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( JX )*TEMP ) - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( J ) ) - DO 50, I = J + 1, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( JX ) ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - A( I, J ) = A( I, J ) + X( IX )*TEMP - 70 CONTINUE - ELSE - A( J, J ) = DBLE( A( J, J ) ) - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHER . -* - END diff --git a/reference/zherkf.f b/reference/zherkf.f deleted file mode 100644 index 5a7e08248..000000000 --- a/reference/zherkf.f +++ /dev/null @@ -1,330 +0,0 @@ - SUBROUTINE ZHERKF( UPLO,TRANS, N, K, ALPHA, A, LDA, BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER TRANS, UPLO - INTEGER K, LDA, LDC, N - DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZHERK performs one of the hermitian rank k operations -* -* C := alpha*A*conjg( A' ) + beta*C, -* -* or -* -* C := alpha*conjg( A' )*A + beta*C, -* -* where alpha and beta are real scalars, C is an n by n hermitian -* matrix and A is an n by k matrix in the first case and a k by n -* matrix in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'C' or 'c', K specifies the number of rows of the -* matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the hermitian matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the hermitian matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -- Modified 8-Nov-93 to set C(J,J) to DBLE( C(J,J) ) when BETA = 1. -* Ed Anderson, Cray Research Inc. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, DCONJG, MAX -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION RTEMP - COMPLEX*16 TEMP -* .. -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) ) THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ) .AND. ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ) .AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) ) THEN - INFO = 2 - ELSE IF( N.LT.0 ) THEN - INFO = 3 - ELSE IF( K.LT.0 ) THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) ) THEN - INFO = 10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZHERK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. - $ ( BETA.EQ.ONE ) ) )RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO ) THEN - IF( UPPER ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 20 J = 1, N - DO 10 I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO ) THEN - DO 60 J = 1, N - DO 50 I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 70 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) ) THEN -* -* Form C := alpha*A*conjg( A' ) + beta*C. -* - IF( UPPER ) THEN - DO 130 J = 1, N - IF( BETA.EQ.ZERO ) THEN - DO 90 I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - DO 100 I = 1, J - 1 - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - C( J, J ) = BETA*DBLE( C( J, J ) ) - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 120 L = 1, K - IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN - TEMP = ALPHA*DCONJG( A( J, L ) ) - DO 110 I = 1, J - 1 - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( TEMP*A( I, L ) ) - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180 J = 1, N - IF( BETA.EQ.ZERO ) THEN - DO 140 I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE ) THEN - C( J, J ) = BETA*DBLE( C( J, J ) ) - DO 150 I = J + 1, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - ELSE - C( J, J ) = DBLE( C( J, J ) ) - END IF - DO 170 L = 1, K - IF( A( J, L ).NE.DCMPLX( ZERO ) ) THEN - TEMP = ALPHA*DCONJG( A( J, L ) ) - C( J, J ) = DBLE( C( J, J ) ) + - $ DBLE( TEMP*A( J, L ) ) - DO 160 I = J + 1, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*conjg( A' )*A + beta*C. -* - IF( UPPER ) THEN - DO 220 J = 1, N - DO 200 I = 1, J - 1 - TEMP = ZERO - DO 190 L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - RTEMP = ZERO - DO 210 L = 1, K - RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) - 210 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) - END IF - 220 CONTINUE - ELSE - DO 260 J = 1, N - RTEMP = ZERO - DO 230 L = 1, K - RTEMP = RTEMP + DCONJG( A( L, J ) )*A( L, J ) - 230 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( J, J ) = ALPHA*RTEMP - ELSE - C( J, J ) = ALPHA*RTEMP + BETA*DBLE( C( J, J ) ) - END IF - DO 250 I = J + 1, N - TEMP = ZERO - DO 240 L = 1, K - TEMP = TEMP + DCONJG( A( L, I ) )*A( L, J ) - 240 CONTINUE - IF( BETA.EQ.ZERO ) THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 250 CONTINUE - 260 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHERK . -* - END diff --git a/reference/zhpmvf.f b/reference/zhpmvf.f deleted file mode 100644 index 8631861b3..000000000 --- a/reference/zhpmvf.f +++ /dev/null @@ -1,270 +0,0 @@ - SUBROUTINE ZHPMVF( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Note that the imaginary parts of the diagonal elements need -* not be set and are assumed to be zero. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK + J - 1 ) ) - $ + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*DBLE( AP( KK ) ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*DBLE( AP( KK ) ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + DCONJG( AP( K ) )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPMV . -* - END diff --git a/reference/zhpr2f.f b/reference/zhpr2f.f deleted file mode 100644 index 462913d4a..000000000 --- a/reference/zhpr2f.f +++ /dev/null @@ -1,251 +0,0 @@ - SUBROUTINE ZHPR2F( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZHPR2 performs the hermitian rank 2 operation -* -* A := alpha*x*conjg( y' ) + conjg( alpha )*y*conjg( x' ) + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) + - $ DBLE( X( JX )*TEMP1 + - $ Y( JY )*TEMP2 ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( J ) ) - TEMP2 = DCONJG( ALPHA*X( J ) ) - AP( KK ) = DBLE( AP( KK ) ) + - $ DBLE( X( J )*TEMP1 + Y( J )*TEMP2 ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*DCONJG( Y( JY ) ) - TEMP2 = DCONJG( ALPHA*X( JX ) ) - AP( KK ) = DBLE( AP( KK ) ) + - $ DBLE( X( JX )*TEMP1 + Y( JY )*TEMP2 ) - IX = JX - IY = JY - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - 70 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPR2 . -* - END diff --git a/reference/zhprf.f b/reference/zhprf.f deleted file mode 100644 index 2c93f1e7e..000000000 --- a/reference/zhprf.f +++ /dev/null @@ -1,217 +0,0 @@ - SUBROUTINE ZHPRF ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZHPR performs the hermitian rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n hermitian matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the hermitian matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, DBLE -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZHPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - K = KK - DO 10, I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - $ + DBLE( X( J )*TEMP ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - IX = KX - DO 30, K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - $ + DBLE( X( JX )*TEMP ) - ELSE - AP( KK + J - 1 ) = DBLE( AP( KK + J - 1 ) ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( J ) ) - AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( J ) ) - K = KK + 1 - DO 50, I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*DCONJG( X( JX ) ) - AP( KK ) = DBLE( AP( KK ) ) + DBLE( TEMP*X( JX ) ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - AP( K ) = AP( K ) + X( IX )*TEMP - 70 CONTINUE - ELSE - AP( KK ) = DBLE( AP( KK ) ) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZHPR . -* - END diff --git a/reference/zlaswpf.f b/reference/zlaswpf.f deleted file mode 100644 index 582f15b52..000000000 --- a/reference/zlaswpf.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE ZLASWPF( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - COMPLEX*16 TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of ZLASWP -* - END diff --git a/reference/zlauu2f.f b/reference/zlauu2f.f deleted file mode 100644 index f53f99d55..000000000 --- a/reference/zlauu2f.f +++ /dev/null @@ -1,143 +0,0 @@ - SUBROUTINE ZLAUU2F( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLAUU2 computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the unblocked form of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, DCMPLX, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLAUU2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I, I+1 ), LDA, - $ A( I, I+1 ), LDA ) ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, DCMPLX( AII ), - $ A( 1, I ), 1 ) - CALL ZLACGV( N-I, A( I, I+1 ), LDA ) - ELSE - CALL ZDSCAL( I, AII, A( 1, I ), 1 ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N - AII = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = AII*AII + DBLE( ZDOTC( N-I, A( I+1, I ), 1, - $ A( I+1, I ), 1 ) ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE, - $ A( I+1, 1 ), LDA, A( I+1, I ), 1, - $ DCMPLX( AII ), A( I, 1 ), LDA ) - CALL ZLACGV( I-1, A( I, 1 ), LDA ) - ELSE - CALL ZDSCAL( I, AII, A( I, 1 ), LDA ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of ZLAUU2 -* - END diff --git a/reference/zlauumf.f b/reference/zlauumf.f deleted file mode 100644 index 3a84646ef..000000000 --- a/reference/zlauumf.f +++ /dev/null @@ -1,160 +0,0 @@ - SUBROUTINE ZLAUUMF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZLAUUM computes the product U * U' or L' * L, where the triangular -* factor U or L is stored in the upper or lower triangular part of -* the array A. -* -* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, -* overwriting the factor U in A. -* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, -* overwriting the factor L in A. -* -* This is the blocked form of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the triangular factor stored in the array A -* is upper or lower triangular: -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the triangular factor U or L. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the triangular factor U or L. -* On exit, if UPLO = 'U', the upper triangle of A is -* overwritten with the upper triangle of the product U * U'; -* if UPLO = 'L', the lower triangle of A is overwritten with -* the lower triangle of the product L' * L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMM, ZHERK, ZLAUU2, ZTRMM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZLAUUM', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 128 -* - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL ZLAUU2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute the product U * U'. -* - DO 10 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose', - $ 'Non-unit', I-1, IB, CONE, A( I, I ), LDA, - $ A( 1, I ), LDA ) - CALL ZLAUU2( 'Upper', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ I-1, IB, N-I-IB+1, CONE, A( 1, I+IB ), - $ LDA, A( I, I+IB ), LDA, CONE, A( 1, I ), - $ LDA ) - CALL ZHERK( 'Upper', 'No transpose', IB, N-I-IB+1, - $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ), - $ LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the product L' * L. -* - DO 20 I = 1, N, NB - IB = MIN( NB, N-I+1 ) - CALL ZTRMM( 'Left', 'Lower', 'Conjugate transpose', - $ 'Non-unit', IB, I-1, CONE, A( I, I ), LDA, - $ A( I, 1 ), LDA ) - CALL ZLAUU2( 'Lower', IB, A( I, I ), LDA, INFO ) - IF( I+IB.LE.N ) THEN - CALL ZGEMM( 'Conjugate transpose', 'No transpose', IB, - $ I-1, N-I-IB+1, CONE, A( I+IB, I ), LDA, - $ A( I+IB, 1 ), LDA, CONE, A( I, 1 ), LDA ) - CALL ZHERK( 'Lower', 'Conjugate transpose', IB, - $ N-I-IB+1, ONE, A( I+IB, I ), LDA, ONE, - $ A( I, I ), LDA ) - END IF - 20 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZLAUUM -* - END diff --git a/reference/zpotf2f.f b/reference/zpotf2f.f deleted file mode 100644 index bfb6f113d..000000000 --- a/reference/zpotf2f.f +++ /dev/null @@ -1,175 +0,0 @@ - SUBROUTINE ZPOTF2F( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZPOTF2 computes the Cholesky factorization of a complex Hermitian -* positive definite matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* Hermitian matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - COMPLEX*16 CONE - PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1, - $ A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL ZLACGV( J-1, A( 1, J ), 1 ) - CALL ZGEMV( 'Transpose', J-1, N-J, -CONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, CONE, A( J, J+1 ), LDA ) - CALL ZLACGV( J-1, A( 1, J ), 1 ) - CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA, - $ A( J, 1 ), LDA ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL ZLACGV( J-1, A( J, 1 ), LDA ) - CALL ZGEMV( 'No transpose', N-J, J-1, -CONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 ) - CALL ZLACGV( J-1, A( J, 1 ), LDA ) - CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of ZPOTF2 -* - END diff --git a/reference/zpotrff.f b/reference/zpotrff.f deleted file mode 100644 index 7cef580a4..000000000 --- a/reference/zpotrff.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE ZPOTRFF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZPOTRF computes the Cholesky factorization of a complex Hermitian -* positive definite matrix A. -* -* The factorization has the form -* A = U**H * U, if UPLO = 'U', or -* A = L * L**H, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the Hermitian matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**H*U or A = L*L**H. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - COMPLEX*16 CONE - PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZGEMM, ZHERK, ZPOTF2, ZTRSM -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = 56 - - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL ZPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL ZHERK( 'Upper', 'Conjugate transpose', JB, J-1, - $ -ONE, A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL ZPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL ZGEMM( 'Conjugate transpose', 'No transpose', JB, - $ N-J-JB+1, J-1, -CONE, A( 1, J ), LDA, - $ A( 1, J+JB ), LDA, CONE, A( J, J+JB ), - $ LDA ) - CALL ZTRSM( 'Left', 'Upper', 'Conjugate transpose', - $ 'Non-unit', JB, N-J-JB+1, CONE, A( J, J ), - $ LDA, A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL ZHERK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL ZPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL ZGEMM( 'No transpose', 'Conjugate transpose', - $ N-J-JB+1, JB, J-1, -CONE, A( J+JB, 1 ), - $ LDA, A( J, 1 ), LDA, CONE, A( J+JB, J ), - $ LDA ) - CALL ZTRSM( 'Right', 'Lower', 'Conjugate transpose', - $ 'Non-unit', N-J-JB+1, JB, CONE, A( J, J ), - $ LDA, A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of ZPOTRF -* - END diff --git a/reference/zpotrif.f b/reference/zpotrif.f deleted file mode 100644 index 5a11880bc..000000000 --- a/reference/zpotrif.f +++ /dev/null @@ -1,96 +0,0 @@ - SUBROUTINE ZPOTRIF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZPOTRI computes the inverse of a complex Hermitian positive definite -* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H -* computed by ZPOTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the triangular factor U or L from the Cholesky -* factorization A = U**H*U or A = L*L**H, as computed by -* ZPOTRF. -* On exit, the upper or lower triangle of the (Hermitian) -* inverse of A, overwriting the input factor U or L. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the (i,i) element of the factor U or L is -* zero, and the inverse could not be computed. -* -* ===================================================================== -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZLAUUM, ZTRTRI -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZPOTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Invert the triangular Cholesky factor U or L. -* - CALL ZTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* -* Form inv(U)*inv(U)' or inv(L)'*inv(L). -* - CALL ZLAUUM( UPLO, N, A, LDA, INFO ) -* - RETURN -* -* End of ZPOTRI -* - END diff --git a/reference/zrotgf.f b/reference/zrotgf.f deleted file mode 100644 index d6f1e0d68..000000000 --- a/reference/zrotgf.f +++ /dev/null @@ -1,23 +0,0 @@ - subroutine zrotgf(ca,cb,c,s) - double complex ca,cb,s - double precision c - double precision norm,scale - double complex alpha - if (cdabs(ca) .ne. 0.0d0) go to 10 - c = 0.0d0 - s = (1.0d0,0.0d0) - ca = cb - go to 20 - 10 continue - scale = cdabs(ca) + cdabs(cb) - - norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 + - * (cdabs(cb/dcmplx(scale,0.0d0)))**2) - - alpha = ca /cdabs(ca) - c = cdabs(ca) / norm - s = alpha * dconjg(cb) / norm - ca = alpha * norm - 20 continue - return - end diff --git a/reference/zsbmvf.f b/reference/zsbmvf.f deleted file mode 100644 index 2b7787c89..000000000 --- a/reference/zsbmvf.f +++ /dev/null @@ -1,306 +0,0 @@ - SUBROUTINE ZSBMVF(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, - $ INCY ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, INCY, K, LDA, N - COMPLEX*16 ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZSBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric band matrix, with k super-diagonals. -* -* Arguments -* ========== -* -* UPLO - CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the band matrix A is being supplied as -* follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* being supplied. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* being supplied. -* -* Unchanged on exit. -* -* N - INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER -* On entry, K specifies the number of super-diagonals of the -* matrix A. K must satisfy 0 .le. K. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array, dimension( LDA, N ) -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - COMPLEX*16 -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - COMPLEX*16 array, dimension at least -* ( 1 + ( N - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L - COMPLEX*16 TEMP1, TEMP2 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( K.LT.0 ) THEN - INFO = 3 - ELSE IF( LDA.LT.( K+1 ) ) THEN - INFO = 6 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 8 - ELSE IF( INCY.EQ.0 ) THEN - INFO = 11 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 ) THEN - KX = 1 - ELSE - KX = 1 - ( N-1 )*INCX - END IF - IF( INCY.GT.0 ) THEN - KY = 1 - ELSE - KY = 1 - ( N-1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array A -* are accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE ) THEN - IF( INCY.EQ.1 ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 10 I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO ) THEN - DO 30 I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 60 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50 I = MAX( 1, J-K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L+I, J ) - TEMP2 = TEMP2 + A( L+I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70 I = MAX( 1, J-K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L+I, J ) - TEMP2 = TEMP2 + A( L+I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K ) THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 100 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( 1, J ) - L = 1 - J - DO 90 I = J + 1, MIN( N, J+K ) - Y( I ) = Y( I ) + TEMP1*A( L+I, J ) - TEMP2 = TEMP2 + A( L+I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) - L = 1 - J - IX = JX - IY = JY - DO 110 I = J + 1, MIN( N, J+K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L+I, J ) - TEMP2 = TEMP2 + A( L+I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSBMV -* - END diff --git a/reference/zscalf.f b/reference/zscalf.f deleted file mode 100644 index f9c2c534b..000000000 --- a/reference/zscalf.f +++ /dev/null @@ -1,29 +0,0 @@ - subroutine zscalf(n,za,zx,incx) -c -c scales a vector by a constant. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex za,zx(*) - integer i,incx,ix,n -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - zx(ix) = za*zx(ix) - ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - zx(i) = za*zx(i) - 30 continue - return - end diff --git a/reference/zspmvf.f b/reference/zspmvf.f deleted file mode 100644 index 8c6057ee3..000000000 --- a/reference/zspmvf.f +++ /dev/null @@ -1,264 +0,0 @@ - SUBROUTINE ZSPMVF(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, INCY, N - COMPLEX*16 ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZSPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix, supplied in packed form. -* -* Arguments -* ========== -* -* UPLO (input) CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N (input) INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA (input) COMPLEX*16 -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP (input) COMPLEX*16 array, dimension at least -* ( ( N*( N + 1 ) )/2 ). -* Before entry, with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry, with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Unchanged on exit. -* -* X (input) COMPLEX*16 array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the N- -* element vector x. -* Unchanged on exit. -* -* INCX (input) INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA (input) COMPLEX*16 -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y (input/output) COMPLEX*16 array, dimension at least -* ( 1 + ( N - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY (input) INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY - COMPLEX*16 TEMP1, TEMP2 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 6 - ELSE IF( INCY.EQ.0 ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 ) THEN - KX = 1 - ELSE - KX = 1 - ( N-1 )*INCX - END IF - IF( INCY.GT.0 ) THEN - KY = 1 - ELSE - KY = 1 - ( N-1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE ) THEN - IF( INCY.EQ.1 ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 10 I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO ) THEN - DO 30 I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 60 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50 I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*AP( KK+J-1 ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 100 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*AP( KK ) - K = KK + 1 - DO 90 I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N-J+1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*AP( KK ) - IX = JX - IY = JY - DO 110 K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N-J+1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSPMV -* - END diff --git a/reference/zspr2f.f b/reference/zspr2f.f deleted file mode 100644 index aad5f718a..000000000 --- a/reference/zspr2f.f +++ /dev/null @@ -1,229 +0,0 @@ - SUBROUTINE ZSPR2F( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSPR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR2 . -* - END diff --git a/reference/zsprf.f b/reference/zsprf.f deleted file mode 100644 index c21f6020b..000000000 --- a/reference/zsprf.f +++ /dev/null @@ -1,213 +0,0 @@ - SUBROUTINE ZSPRF( UPLO, N, ALPHA, X, INCX, AP ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, N - COMPLEX*16 ALPHA -* .. -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZSPR performs the symmetric rank 1 operation -* -* A := alpha*x*conjg( x' ) + A, -* -* where alpha is a complex scalar, x is an n element vector and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Arguments -* ========== -* -* UPLO (input) CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N (input) INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA (input) COMPLEX*16 -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X (input) COMPLEX*16 array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the N- -* element vector x. -* Unchanged on exit. -* -* INCX (input) INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP (input/output) COMPLEX*16 array, dimension at least -* ( ( N*( N + 1 ) )/2 ). -* Before entry, with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry, with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* Note that the imaginary parts of the diagonal elements need -* not be set, they are assumed to be zero, and on exit they -* are set to zero. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, J, JX, K, KK, KX - COMPLEX*16 TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 ) THEN - KX = 1 - ( N-1 )*INCX - ELSE IF( INCX.NE.1 ) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 ) THEN - DO 20 J = 1, N - IF( X( J ).NE.ZERO ) THEN - TEMP = ALPHA*X( J ) - K = KK - DO 10 I = 1, J - 1 - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - AP( KK+J-1 ) = AP( KK+J-1 ) + X( J )*TEMP - ELSE - AP( KK+J-1 ) = AP( KK+J-1 ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1, N - IF( X( JX ).NE.ZERO ) THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30 K = KK, KK + J - 2 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - AP( KK+J-1 ) = AP( KK+J-1 ) + X( JX )*TEMP - ELSE - AP( KK+J-1 ) = AP( KK+J-1 ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 ) THEN - DO 60 J = 1, N - IF( X( J ).NE.ZERO ) THEN - TEMP = ALPHA*X( J ) - AP( KK ) = AP( KK ) + TEMP*X( J ) - K = KK + 1 - DO 50 I = J + 1, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - ELSE - AP( KK ) = AP( KK ) - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1, N - IF( X( JX ).NE.ZERO ) THEN - TEMP = ALPHA*X( JX ) - AP( KK ) = AP( KK ) + TEMP*X( JX ) - IX = JX - DO 70 K = KK + 1, KK + N - J - IX = IX + INCX - AP( K ) = AP( K ) + X( IX )*TEMP - 70 CONTINUE - ELSE - AP( KK ) = AP( KK ) - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSPR -* - END diff --git a/reference/zswapf.f b/reference/zswapf.f deleted file mode 100644 index f42d7ec5d..000000000 --- a/reference/zswapf.f +++ /dev/null @@ -1,36 +0,0 @@ - subroutine zswapf (n,zx,incx,zy,incy) -c -c interchanges two vectors. -c jack dongarra, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*),zy(*),ztemp - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - ztemp = zx(ix) - zx(ix) = zy(iy) - zy(iy) = ztemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 - 20 do 30 i = 1,n - ztemp = zx(i) - zx(i) = zy(i) - zy(i) = ztemp - 30 continue - return - end diff --git a/reference/zsymm3mf.f b/reference/zsymm3mf.f deleted file mode 100644 index 82423babf..000000000 --- a/reference/zsymm3mf.f +++ /dev/null @@ -1,296 +0,0 @@ - SUBROUTINE ZSYMM3MF( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the symmetric matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the symmetric matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* symmetric matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* symmetric matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of ZSYMM . -* - END diff --git a/reference/zsymmf.f b/reference/zsymmf.f deleted file mode 100644 index ce24be4d1..000000000 --- a/reference/zsymmf.f +++ /dev/null @@ -1,296 +0,0 @@ - SUBROUTINE ZSYMMF ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the symmetric matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the symmetric matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* symmetric matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* symmetric matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - COMPLEX*16 array of 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 updated -* matrix. -* -* LDC - 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 ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when 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( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of ZSYMM . -* - END diff --git a/reference/zsymvf.f b/reference/zsymvf.f deleted file mode 100644 index 7161f1a81..000000000 --- a/reference/zsymvf.f +++ /dev/null @@ -1,264 +0,0 @@ - SUBROUTINE ZSYMVF(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, INCY, LDA, N - COMPLEX*16 ALPHA, BETA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* ZSYMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix. -* -* Arguments -* ========== -* -* UPLO (input) CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N (input) INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA (input) COMPLEX*16 -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A (input) COMPLEX*16 array, dimension ( LDA, N ) -* Before entry, with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry, with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. -* Unchanged on exit. -* -* LDA (input) INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, N ). -* Unchanged on exit. -* -* X (input) COMPLEX*16 array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the N- -* element vector x. -* Unchanged on exit. -* -* INCX (input) INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA (input) COMPLEX*16 -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y (input/output) COMPLEX*16 array, dimension at least -* ( 1 + ( N - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY (input) INTEGER -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY - COMPLEX*16 TEMP1, TEMP2 -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = 5 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 7 - ELSE IF( INCY.EQ.0 ) THEN - INFO = 10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSYMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 ) THEN - KX = 1 - ELSE - KX = 1 - ( N-1 )*INCX - END IF - IF( INCY.GT.0 ) THEN - KY = 1 - ELSE - KY = 1 - ( N-1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE ) THEN - IF( INCY.EQ.1 ) THEN - IF( BETA.EQ.ZERO ) THEN - DO 10 I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20 I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO ) THEN - DO 30 I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40 I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 60 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50 I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70 I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) ) THEN - DO 100 J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( J, J ) - DO 90 I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120 J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) - IX = JX - IY = JY - DO 110 I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSYMV -* - END diff --git a/reference/zsyr2f.f b/reference/zsyr2f.f deleted file mode 100644 index d77e4d211..000000000 --- a/reference/zsyr2f.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE ZSYR2F ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - COMPLEX*16 ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - COMPLEX*16 TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2 . -* - END diff --git a/reference/zsyr2kf.f b/reference/zsyr2kf.f deleted file mode 100644 index f6f0992d9..000000000 --- a/reference/zsyr2kf.f +++ /dev/null @@ -1,324 +0,0 @@ - SUBROUTINE ZSYR2KF( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -* beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'T' or 't', K specifies the number of rows of the -* matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP1, TEMP2 -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + A( I, L )*TEMP1 + - $ B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSYR2K. -* - END diff --git a/reference/zsyrf.f b/reference/zsyrf.f deleted file mode 100644 index 4262ed9be..000000000 --- a/reference/zsyrf.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE ZSYRF( UPLO, N, ALPHA, X, INCX, A, LDA ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INCX, LDA, N - COMPLEX*16 ALPHA -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZSYR performs the symmetric rank 1 operation -* -* A := alpha*x*( x' ) + A, -* -* where alpha is a complex scalar, x is an n element vector and A is an -* n by n symmetric matrix. -* -* Arguments -* ========== -* -* UPLO (input) CHARACTER*1 -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N (input) INTEGER -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA (input) COMPLEX*16 -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X (input) COMPLEX*16 array, dimension at least -* ( 1 + ( N - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the N- -* element vector x. -* Unchanged on exit. -* -* INCX (input) INTEGER -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A (input/output) COMPLEX*16 array, dimension ( LDA, N ) -* Before entry, with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry, with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA (input) INTEGER -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, N ). -* Unchanged on exit. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, IX, J, JX, KX - COMPLEX*16 TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = 1 - ELSE IF( N.LT.0 ) THEN - INFO = 2 - ELSE IF( INCX.EQ.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = 7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZSYR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ) .OR. ( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 ) THEN - KX = 1 - ( N-1 )*INCX - ELSE IF( INCX.NE.1 ) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 ) THEN - DO 20 J = 1, N - IF( X( J ).NE.ZERO ) THEN - TEMP = ALPHA*X( J ) - DO 10 I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40 J = 1, N - IF( X( JX ).NE.ZERO ) THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30 I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 ) THEN - DO 60 J = 1, N - IF( X( J ).NE.ZERO ) THEN - TEMP = ALPHA*X( J ) - DO 50 I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1, N - IF( X( JX ).NE.ZERO ) THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70 I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSYR -* - END diff --git a/reference/zsyrkf.f b/reference/zsyrkf.f deleted file mode 100644 index 99bfa8250..000000000 --- a/reference/zsyrkf.f +++ /dev/null @@ -1,293 +0,0 @@ - SUBROUTINE ZSYRKF ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - COMPLEX*16 ALPHA, BETA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* ZSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't', K specifies the number of rows of the -* matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - COMPLEX*16 . -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - COMPLEX*16 array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZSYRK . -* - END diff --git a/reference/ztbmvf.f b/reference/ztbmvf.f deleted file mode 100644 index 8df5609ad..000000000 --- a/reference/ztbmvf.f +++ /dev/null @@ -1,378 +0,0 @@ - SUBROUTINE ZTBMVF( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTBMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular band matrix, with ( k + 1 ) diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := conjg( A' )*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ).OR.LSAME( TRANS, 'R' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = KPLUS1 - J - DO 10, I = MAX( 1, J - K ), J - 1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( KPLUS1, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 30, I = MAX( 1, J - K ), J - 1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( KPLUS1, J ) - END IF - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = 1 - J - DO 50, I = MIN( N, J + K ), J + 1, -1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( 1, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 70, I = MIN( N, J + K ), J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( 1, J ) - END IF - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - L = KPLUS1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 90, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( I ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( KPLUS1, J ) ) - DO 100, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + DCONJG( A( L + I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - KX = KX - INCX - IX = KX - L = KPLUS1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 120, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX - INCX - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( KPLUS1, J ) ) - DO 130, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + DCONJG( A( L + I, J ) )*X( IX ) - IX = IX - INCX - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - L = 1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 150, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( 1, J ) ) - DO 160, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + DCONJG( A( L + I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - KX = KX + INCX - IX = KX - L = 1 - J - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 180, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX + INCX - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( 1, J ) ) - DO 190, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + DCONJG( A( L + I, J ) )*X( IX ) - IX = IX + INCX - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTBMV . -* - END diff --git a/reference/ztbsvf.f b/reference/ztbsvf.f deleted file mode 100644 index 78c37e3d4..000000000 --- a/reference/ztbsvf.f +++ /dev/null @@ -1,367 +0,0 @@ - SUBROUTINE ZTBSVF(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) -* .. Scalar Arguments .. - INTEGER INCX,K,LDA,N - CHARACTER DIAG,TRANS,UPLO -* .. -* .. Array Arguments .. - DOUBLE COMPLEX A(LDA,*),X(*) -* .. -* -* Purpose -* ======= -* -* ZTBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Arguments -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE COMPLEX ZERO - PARAMETER (ZERO= (0.0D+0,0.0D+0)) -* .. -* .. Local Scalars .. - DOUBLE COMPLEX TEMP - INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L - LOGICAL NOCONJ,NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC DCONJG,MAX,MIN -* .. -* -* Test the input parameters. -* - INFO = 0 - IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN - INFO = 1 - ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND. - + .NOT.LSAME(TRANS,'C')) THEN - INFO = 2 - ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN - INFO = 3 - ELSE IF (N.LT.0) THEN - INFO = 4 - ELSE IF (K.LT.0) THEN - INFO = 5 - ELSE IF (LDA.LT. (K+1)) THEN - INFO = 7 - ELSE IF (INCX.EQ.0) THEN - INFO = 9 - END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZTBSV ',INFO) - RETURN - END IF -* -* Quick return if possible. -* - IF (N.EQ.0) RETURN -* - NOCONJ = LSAME(TRANS,'T') - NOUNIT = LSAME(DIAG,'N') -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF (INCX.LE.0) THEN - KX = 1 - (N-1)*INCX - ELSE IF (INCX.NE.1) THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF (LSAME(TRANS,'N')) THEN -* -* Form x := inv( A )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 20 J = N,1,-1 - IF (X(J).NE.ZERO) THEN - L = KPLUS1 - J - IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J) - TEMP = X(J) - DO 10 I = J - 1,MAX(1,J-K),-1 - X(I) = X(I) - TEMP*A(L+I,J) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 40 J = N,1,-1 - KX = KX - INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = KPLUS1 - J - IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J) - TEMP = X(JX) - DO 30 I = J - 1,MAX(1,J-K),-1 - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 60 J = 1,N - IF (X(J).NE.ZERO) THEN - L = 1 - J - IF (NOUNIT) X(J) = X(J)/A(1,J) - TEMP = X(J) - DO 50 I = J + 1,MIN(N,J+K) - X(I) = X(I) - TEMP*A(L+I,J) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80 J = 1,N - KX = KX + INCX - IF (X(JX).NE.ZERO) THEN - IX = KX - L = 1 - J - IF (NOUNIT) X(JX) = X(JX)/A(1,J) - TEMP = X(JX) - DO 70 I = J + 1,MIN(N,J+K) - X(IX) = X(IX) - TEMP*A(L+I,J) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A') )*x. -* - IF (LSAME(UPLO,'U')) THEN - KPLUS1 = K + 1 - IF (INCX.EQ.1) THEN - DO 110 J = 1,N - TEMP = X(J) - L = KPLUS1 - J - IF (NOCONJ) THEN - DO 90 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(I) - 90 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - ELSE - DO 100 I = MAX(1,J-K),J - 1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(I) - 100 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J)) - END IF - X(J) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140 J = 1,N - TEMP = X(JX) - IX = KX - L = KPLUS1 - J - IF (NOCONJ) THEN - DO 120 I = MAX(1,J-K),J - 1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX + INCX - 120 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J) - ELSE - DO 130 I = MAX(1,J-K),J - 1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(IX) - IX = IX + INCX - 130 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(KPLUS1,J)) - END IF - X(JX) = TEMP - JX = JX + INCX - IF (J.GT.K) KX = KX + INCX - 140 CONTINUE - END IF - ELSE - IF (INCX.EQ.1) THEN - DO 170 J = N,1,-1 - TEMP = X(J) - L = 1 - J - IF (NOCONJ) THEN - DO 150 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(I) - 150 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - ELSE - DO 160 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(I) - 160 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J)) - END IF - X(J) = TEMP - 170 CONTINUE - ELSE - KX = KX + (N-1)*INCX - JX = KX - DO 200 J = N,1,-1 - TEMP = X(JX) - IX = KX - L = 1 - J - IF (NOCONJ) THEN - DO 180 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - A(L+I,J)*X(IX) - IX = IX - INCX - 180 CONTINUE - IF (NOUNIT) TEMP = TEMP/A(1,J) - ELSE - DO 190 I = MIN(N,J+K),J + 1,-1 - TEMP = TEMP - DCONJG(A(L+I,J))*X(IX) - IX = IX - INCX - 190 CONTINUE - IF (NOUNIT) TEMP = TEMP/DCONJG(A(1,J)) - END IF - X(JX) = TEMP - JX = JX - INCX - IF ((N-J).GE.K) KX = KX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTBSV . -* - END diff --git a/reference/ztpmvf.f b/reference/ztpmvf.f deleted file mode 100644 index 7e52ef74e..000000000 --- a/reference/ztpmvf.f +++ /dev/null @@ -1,377 +0,0 @@ - SUBROUTINE ZTPMVF( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTPMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := conjg( A' )*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTPMVF', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ).OR.LSAME( TRANS, 'R' ))THEN -* -* Form x:= A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 10, I = 1, J - 1 - IF( NOCONJ )THEN - X( I ) = X( I ) + TEMP*AP( K ) - ELSE - X( I ) = X( I ) + TEMP*DCONJG(AP( K )) - END IF - K = K + 1 - 10 CONTINUE - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK + J - 1 ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )*DCONJG(AP( KK + J-1)) - END IF - END IF - - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, K = KK, KK + J - 2 - IF( NOCONJ )THEN - X( IX ) = X( IX ) + TEMP*AP( K ) - ELSE - X( IX ) = X( IX ) + TEMP*DCONJG(AP(K)) - END IF - IX = IX + INCX - 30 CONTINUE - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK + J - 1 ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )*DCONJG(AP( KK + J-1)) - END IF - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 50, I = N, J + 1, -1 - IF( NOCONJ )THEN - X( I ) = X( I ) + TEMP*AP( K ) - ELSE - X( I ) = X( I ) + TEMP*DCONJG(AP( K )) - END IF - K = K - 1 - 50 CONTINUE - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK - N + J ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )*DCONJG(AP(KK - N+J)) - END IF - - END IF - KK = KK - ( N - J + 1 ) - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 - IF( NOCONJ )THEN - X( IX ) = X( IX ) + TEMP*AP( K ) - ELSE - X( IX ) = X( IX ) + TEMP*DCONJG(AP(K)) - ENDIF - IX = IX - INCX - 70 CONTINUE - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK - N + J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )*DCONJG(AP(KK-N+J)) - ENDIF - END IF - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - K = KK - 1 - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + AP( K )*X( I ) - K = K - 1 - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( AP( KK ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + DCONJG( AP( K ) )*X( I ) - K = K - 1 - 100 CONTINUE - END IF - X( J ) = TEMP - KK = KK - J - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 120, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + AP( K )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( AP( KK ) ) - DO 130, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + DCONJG( AP( K ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - KK = KK - J - 140 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - K = KK + 1 - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 150, I = J + 1, N - TEMP = TEMP + AP( K )*X( I ) - K = K + 1 - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( AP( KK ) ) - DO 160, I = J + 1, N - TEMP = TEMP + DCONJG( AP( K ) )*X( I ) - K = K + 1 - 160 CONTINUE - END IF - X( J ) = TEMP - KK = KK + ( N - J + 1 ) - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 180, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + AP( K )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( AP( KK ) ) - DO 190, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + DCONJG( AP( K ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTPMV . -* - END diff --git a/reference/ztpsvf.f b/reference/ztpsvf.f deleted file mode 100644 index d5a981efd..000000000 --- a/reference/ztpsvf.f +++ /dev/null @@ -1,379 +0,0 @@ - SUBROUTINE ZTPSVF( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTPSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix, supplied in packed form. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - COMPLEX*16 array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTPSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) .OR.LSAME( TRANS, 'R' ))THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )/DCONJG(AP( KK )) - END IF - - TEMP = X( J ) - K = KK - 1 - DO 10, I = J - 1, 1, -1 - IF( NOCONJ )THEN - X( I ) = X( I ) - TEMP*AP( K ) - ELSE - X( I ) = X( I ) - TEMP*DCONJG(AP( K )) - END IF - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )/DCONJG(AP( KK )) - END IF - TEMP = X( JX ) - IX = JX - DO 30, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - IF( NOCONJ )THEN - X( IX ) = X( IX ) - TEMP*AP( K ) - ELSE - X( IX ) = X( IX ) - TEMP*DCONJG(AP( K )) - END IF - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )/DCONJG(AP( KK )) - END IF - TEMP = X( J ) - K = KK + 1 - DO 50, I = J + 1, N - IF( NOCONJ )THEN - X( I ) = X( I ) - TEMP*AP( K ) - ELSE - X( I ) = X( I ) - TEMP*DCONJG(AP( K )) - END IF - K = K + 1 - 50 CONTINUE - END IF - KK = KK + ( N - J + 1 ) - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOCONJ )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )/DCONJG(AP( KK )) - END IF - TEMP = X( JX ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - IF( NOCONJ )THEN - X( IX ) = X( IX ) - TEMP*AP( K ) - ELSE - X( IX ) = X( IX ) - TEMP*DCONJG(AP( K )) - END IF - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - K = KK - IF( NOCONJ )THEN - DO 90, I = 1, J - 1 - TEMP = TEMP - AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - DCONJG( AP( K ) )*X( I ) - K = K + 1 - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( AP( KK + J - 1 ) ) - END IF - X( J ) = TEMP - KK = KK + J - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - TEMP = X( JX ) - IX = KX - IF( NOCONJ )THEN - DO 120, K = KK, KK + J - 2 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - ELSE - DO 130, K = KK, KK + J - 2 - TEMP = TEMP - DCONJG( AP( K ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( AP( KK + J - 1 ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - KK = KK + J - 140 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - K = KK - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - AP( K )*X( I ) - K = K - 1 - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - DCONJG( AP( K ) )*X( I ) - K = K - 1 - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( AP( KK - N + J ) ) - END IF - X( J ) = TEMP - KK = KK - ( N - J + 1 ) - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - IF( NOCONJ )THEN - DO 180, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - ELSE - DO 190, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - DCONJG( AP( K ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( AP( KK - N + J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTPSV . -* - END diff --git a/reference/ztrmmf.f b/reference/ztrmmf.f deleted file mode 100644 index d286f9673..000000000 --- a/reference/ztrmmf.f +++ /dev/null @@ -1,428 +0,0 @@ - SUBROUTINE ZTRMMF ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX*16 ALPHA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ) -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'R' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'R' ))THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - IF (NOCONJ) THEN - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - ELSE - DO 35, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*DCONJG(A( I, K )) - 35 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG(A( K, K )) - B( K, J ) = TEMP - ENDIF - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF (NOCONJ) THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - ELSE - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*DCONJG(A( K, K )) - DO 65, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*DCONJG(A( I, K )) - 65 CONTINUE - ENDIF - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B or B := alpha*conjg( A' )*B. -* - IF( UPPER )THEN - DO 120, J = 1, N - DO 110, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( I, I ) ) - DO 100, K = 1, I - 1 - TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) - 100 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 110 CONTINUE - 120 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = 1, M - TEMP = B( I, J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 130, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 130 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( I, I ) ) - DO 140, K = I + 1, M - TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) - 140 CONTINUE - END IF - B( I, J ) = ALPHA*TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'R' ))THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 200, J = N, 1, -1 - TEMP = ALPHA - IF (NOCONJ) THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG(A( J, J )) - ENDIF - DO 170, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 170 CONTINUE - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - IF (NOCONJ) THEN - TEMP = ALPHA*A( K, J ) - ELSE - TEMP = ALPHA*DCONJG(A( K, J )) - ENDIF - DO 180, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - 200 CONTINUE - ELSE - DO 240, J = 1, N - TEMP = ALPHA - IF (NOCONJ) THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG(A( J, J )) - ENDIF - DO 210, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 210 CONTINUE - DO 230, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - IF (NOCONJ) THEN - TEMP = ALPHA*A( K, J ) - ELSE - TEMP = ALPHA*DCONJG(A( K, J )) - ENDIF - DO 220, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 220 CONTINUE - END IF - 230 CONTINUE - 240 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A' or B := alpha*B*conjg( A' ). -* - IF( UPPER )THEN - DO 280, K = 1, N - DO 260, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 250, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*DCONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - ELSE - DO 320, K = N, 1, -1 - DO 300, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = ALPHA*A( J, K ) - ELSE - TEMP = ALPHA*DCONJG( A( J, K ) ) - END IF - DO 290, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - TEMP = ALPHA - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = TEMP*A( K, K ) - ELSE - TEMP = TEMP*DCONJG( A( K, K ) ) - END IF - END IF - IF( TEMP.NE.ONE )THEN - DO 310, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 310 CONTINUE - END IF - 320 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMM . -* - END diff --git a/reference/ztrmvf.f b/reference/ztrmvf.f deleted file mode 100644 index 9e4f85380..000000000 --- a/reference/ztrmvf.f +++ /dev/null @@ -1,358 +0,0 @@ - SUBROUTINE ZTRMVF ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, or x := conjg( A' )*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := conjg( A' )*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'R' ))THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - IF (NOCONJ) THEN - X( I ) = X( I ) + TEMP*A( I, J ) - ELSE - X( I ) = X( I ) + TEMP*DCONJG(A( I, J )) - ENDIF - 10 CONTINUE - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )*DCONJG(A( J, J )) - ENDIF - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - IF (NOCONJ) THEN - X( IX ) = X( IX ) + TEMP*A( I, J ) - ELSE - X( IX ) = X( IX ) + TEMP*DCONJG(A( I, J )) - ENDIF - IX = IX + INCX - 30 CONTINUE - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )*DCONJG(A( J, J )) - ENDIF - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - IF (NOCONJ) THEN - X( I ) = X( I ) + TEMP*A( I, J ) - ELSE - X( I ) = X( I ) + TEMP*DCONJG(A( I, J )) - ENDIF - 50 CONTINUE - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )*DCONJG(A( J, J )) - ENDIF - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - IF (NOCONJ) THEN - X( IX ) = X( IX ) + TEMP*A( I, J ) - ELSE - X( IX ) = X( IX ) + TEMP*DCONJG(A( I, J )) - ENDIF - IX = IX - INCX - 70 CONTINUE - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )*DCONJG(A( J, J )) - ENDIF - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x or x := conjg( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 100, I = J - 1, 1, -1 - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - 100 CONTINUE - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 140, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 120, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 120 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 130, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - 130 CONTINUE - END IF - X( JX ) = TEMP - JX = JX - INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 150 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 160, I = J + 1, N - TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) - 160 CONTINUE - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - JX = KX - DO 200, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOCONJ )THEN - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 180, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 180 CONTINUE - ELSE - IF( NOUNIT ) - $ TEMP = TEMP*DCONJG( A( J, J ) ) - DO 190, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) - 190 CONTINUE - END IF - X( JX ) = TEMP - JX = JX + INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRMV . -* - END diff --git a/reference/ztrsmf.f b/reference/ztrsmf.f deleted file mode 100644 index ed7d22778..000000000 --- a/reference/ztrsmf.f +++ /dev/null @@ -1,457 +0,0 @@ - SUBROUTINE ZTRSMF ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - IMPLICIT NONE - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - COMPLEX*16 ALPHA -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* ZTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - 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'. -* -* TRANSA = 'C' or 'c' op( A ) = conjg( A' ). -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - COMPLEX*16 . -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - COMPLEX*16 array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* 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. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - COMPLEX*16 TEMP -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOCONJ = (LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'T' )) - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'R' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'R' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) THEN - IF (NOCONJ) THEN - B( K, J ) = B( K, J )/A( K, K ) - ELSE - B( K, J ) = B( K, J )/DCONJG(A( K, K )) - ENDIF - ENDIF - IF (NOCONJ) THEN - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - ELSE - DO 45, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*DCONJG(A( I, K )) - 45 CONTINUE - ENDIF - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF (NOCONJ) THEN - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - ELSE - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/DCONJG(A( K, K )) - DO 85, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*DCONJG(A( I, K )) - 85 CONTINUE - END IF - ENDIF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B -* or B := alpha*inv( conjg( A' ) )*B. -* - IF( UPPER )THEN - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 120, K = 1, I - 1 - TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 130 CONTINUE - 140 CONTINUE - ELSE - DO 180, J = 1, N - DO 170, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - IF( NOCONJ )THEN - DO 150, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - ELSE - DO 160, K = I + 1, M - TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( I, I ) ) - END IF - B( I, J ) = TEMP - 170 CONTINUE - 180 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) .OR. LSAME( TRANSA, 'R' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 230, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 190, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 190 CONTINUE - END IF - DO 210, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - IF (NOCONJ) THEN - DO 200, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 200 CONTINUE - ELSE - DO 205, I = 1, M - B( I, J ) = B( I, J ) - DCONJG(A( K, J ))*B( I, K ) - 205 CONTINUE - ENDIF - END IF - 210 CONTINUE - IF( NOUNIT )THEN - IF (NOCONJ) THEN - TEMP = ONE/A( J, J ) - ELSE - TEMP = ONE/DCONJG(A( J, J )) - ENDIF - DO 220, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 220 CONTINUE - END IF - 230 CONTINUE - ELSE - DO 280, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 240, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 240 CONTINUE - END IF - DO 260, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - IF (NOCONJ) THEN - DO 250, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 250 CONTINUE - ELSE - DO 255, I = 1, M - B( I, J ) = B( I, J ) - DCONJG(A( K, J ))*B( I, K ) - 255 CONTINUE - ENDIF - END IF - 260 CONTINUE - IF( NOUNIT )THEN - IF (NOCONJ) THEN - TEMP = ONE/A( J, J ) - ELSE - TEMP = ONE/DCONJG(A( J, J )) - ENDIF - DO 270, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 270 CONTINUE - END IF - 280 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ) -* or B := alpha*B*inv( conjg( A' ) ). -* - IF( UPPER )THEN - DO 330, K = N, 1, -1 - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/DCONJG( A( K, K ) ) - END IF - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - DO 310, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = DCONJG( A( J, K ) ) - END IF - DO 300, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 320, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 320 CONTINUE - END IF - 330 CONTINUE - ELSE - DO 380, K = 1, N - IF( NOUNIT )THEN - IF( NOCONJ )THEN - TEMP = ONE/A( K, K ) - ELSE - TEMP = ONE/DCONJG( A( K, K ) ) - END IF - DO 340, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 340 CONTINUE - END IF - DO 360, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - IF( NOCONJ )THEN - TEMP = A( J, K ) - ELSE - TEMP = DCONJG( A( J, K ) ) - END IF - DO 350, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 370, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 370 CONTINUE - END IF - 380 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRSM . -* - END diff --git a/reference/ztrsvf.f b/reference/ztrsvf.f deleted file mode 100644 index c8b3d542f..000000000 --- a/reference/ztrsvf.f +++ /dev/null @@ -1,361 +0,0 @@ - SUBROUTINE ZTRSVF ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* ZTRSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, or conjg( A' )*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' conjg( A' )*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - COMPLEX*16 array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - COMPLEX*16 array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. Local Scalars .. - COMPLEX*16 TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOCONJ, NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC DCONJG, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'R' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'ZTRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOCONJ = LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) - NOUNIT = LSAME( DIAG , 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'R' ) ) THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )/DCONJG(A( J, J )) - TEMP = X( J ) - DO 15, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*DCONJG(A( I, J )) - 15 CONTINUE - ENDIF - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )/DCONJG(A( J, J )) - ENDIF - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - IF (NOCONJ) THEN - X( IX ) = X( IX ) - TEMP*A( I, J ) - ELSE - X( IX ) = X( IX ) - TEMP*DCONJG(A( I, J )) - ENDIF - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - ELSE - IF( NOUNIT ) - $ X( J ) = X( J )/DCONJG(A( J, J )) - TEMP = X( J ) - DO 55, I = J + 1, N - X( I ) = X( I ) - TEMP*DCONJG(A( I, J )) - 55 CONTINUE - ENDIF - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF (NOCONJ) THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - ELSE - IF( NOUNIT ) - $ X( JX ) = X( JX )/DCONJG(A( J, J )) - ENDIF - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - IF (NOCONJ) THEN - X( IX ) = X( IX ) - TEMP*A( I, J ) - ELSE - X( IX ) = X( IX ) - TEMP*DCONJG(A( I, J )) - ENDIF - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 110, J = 1, N - TEMP = X( J ) - IF( NOCONJ )THEN - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 100, I = 1, J - 1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) - 100 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 110 CONTINUE - ELSE - JX = KX - DO 140, J = 1, N - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 120, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 120 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 130, I = 1, J - 1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) - IX = IX + INCX - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX + INCX - 140 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 170, J = N, 1, -1 - TEMP = X( J ) - IF( NOCONJ )THEN - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 160, I = N, J + 1, -1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) - 160 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( J ) = TEMP - 170 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 200, J = N, 1, -1 - IX = KX - TEMP = X( JX ) - IF( NOCONJ )THEN - DO 180, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 180 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - ELSE - DO 190, I = N, J + 1, -1 - TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) - IX = IX - INCX - 190 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/DCONJG( A( J, J ) ) - END IF - X( JX ) = TEMP - JX = JX - INCX - 200 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of ZTRSV . -* - END diff --git a/reference/ztrti2f.f b/reference/ztrti2f.f deleted file mode 100644 index a40d2ed57..000000000 --- a/reference/ztrti2f.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE ZTRTI2F( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZTRTI2 computes the inverse of a complex upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - COMPLEX*16 AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZSCAL, ZTRMV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL ZTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL ZSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL ZTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL ZSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of ZTRTI2 -* - END diff --git a/reference/ztrtrif.f b/reference/ztrtrif.f deleted file mode 100644 index f68caf4b6..000000000 --- a/reference/ztrtrif.f +++ /dev/null @@ -1,177 +0,0 @@ - SUBROUTINE ZTRTRIF( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* ZTRTRI computes the inverse of a complex upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) COMPLEX*16 array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - COMPLEX*16 ONE, ZERO - PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), - $ ZERO = ( 0.0D+0, 0.0D+0 ) ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA, ZTRMM, ZTRSM, ZTRTI2 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'ZTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = 128 - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL ZTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL ZTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL ZTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL ZTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL ZTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL ZTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of ZTRTRI -* - END