actually remove the files
This commit is contained in:
User User-User
parent
e7910d098d
commit
379858b66e
|
|
@ -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
|
||||
|
|
@ -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.
|
||||
|
|
@ -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) $^
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue