arpack-akloeckner-07/0000755000175000017500000000000010670624440014476 5ustar andreasandreasarpack-akloeckner-07/ARMAKES/0000755000175000017500000000000006215635372015567 5ustar andreasandreasarpack-akloeckner-07/ARMAKES/ARmake.CRAY0000644000175000017500000000715206141016551017402 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: ARmake.inc # # Purpose: Top-level Definitions # # Creation date: February 22, 1996 # # Modified: # # Send bug reports, comments or suggestions to arpack@caam.rice.edu # ############################################################################# # # %---------------------------------% # | SECTION 1: PATHS AND LIBRARIES | # %---------------------------------% # # %--------------------------------------% # | You should change the definition of | # | home if ARPACK is built somewhere | # | other than your home directory. | # %--------------------------------------% # home = $(HOME)/ARPACK # # %--------------------------------------% # | The platform identifier to suffix to | # | the end of library names | # %--------------------------------------% # PLAT = CRAY # # %------------------------------------------------------% # | The directories to find the various pieces of ARPACK | # %------------------------------------------------------% # BLASdir = $(home)/BLAS LAPACKdir = $(home)/LAPACK UTILdir = $(home)/UTIL SRCdir = $(home)/SRC # DIRS = $(BLASdir) $(LAPACKdir) $(UTILdir) $(SRCdir) # # %-------------------------------------------------------------------% # | Comment out the previous line and uncomment the following | # | if you already have the BLAS and LAPACK installed on your system. | # | NOTE: ARPACK assumes the use of LAPACK version 2 codes. | # %-------------------------------------------------------------------% # #DIRS = $(UTILdir) $(SRCdir) # # %---------------------------------------------------% # | The name of the libraries to be created/linked to | # %---------------------------------------------------% # ARPACKLIB = $(home)/libarpack_$(PLAT).a LAPACKLIB = BLASLIB = # ALIBS = $(ARPACKLIB) $(LAPACKLIB) $(BLASLIB) # # # %---------------------------------------------------------% # | SECTION 2: COMPILERS | # | | # | The following macros specify compilers, linker/loaders, | # | the archiver, and their options. You need to make sure | # | these are correct for your system. | # %---------------------------------------------------------% # # %------------------------------% # | Make our own suffixes' list. | # %------------------------------% # .SUFFIXES: .SUFFIXES: .f .o # # %------------------% # | Default command. | # %------------------% # .DEFAULT: @$(ECHO) "Unknown target $@, try: make help" # # %-------------------------------------------% # | Command to build .o files from .f files. | # %-------------------------------------------% # .f.o: @$(ECHO) Making $@ from $< @$(FC) -c $(FFLAGS) $< # # %-----------------------------------------% # | Various compilation programs and flags. | # | You need to make sure these are correct | # | for your system. | # %-----------------------------------------% # FC = cf77 FFLAGS = -Wf,"-dp" LDFLAGS = CD = cd ECHO = echo LN = ln LNFLAGS = -s MAKE = /bin/make RM = rm RMFLAGS = -f SHELL = /bin/sh # # %--------------------------------------------% # | For System V based machine without ranlib, | # | like Cray and SGI, use touch instead. | # %--------------------------------------------% # AR = ar ARFLAGS = rv RANLIB = touch #RANLIB = ranlib # # %----------------------------------% # | This is the general help target. | # %----------------------------------% # help: @$(ECHO) "usage: make ?" arpack-akloeckner-07/ARMAKES/ARmake.SGI0000644000175000017500000000716106127271522017273 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: ARmake.inc # # Purpose: Top-level Definitions # # Creation date: February 22, 1996 # # Modified: # # Send bug reports, comments or suggestions to arpack@caam.rice.edu # ############################################################################ # # %---------------------------------% # | SECTION 1: PATHS AND LIBRARIES | # %---------------------------------% # # %--------------------------------------% # | You should change the definition of | # | home if ARPACK is built some place | # | other than your home directory. | # %--------------------------------------% # home = $(HOME)/ARPACK # # %--------------------------------------% # | The platform identifier to suffix to | # | the end of library names | # %--------------------------------------% # PLAT = SGI # # %------------------------------------------------------% # | The directories to find the various pieces of ARPACK | # %------------------------------------------------------% # BLASdir = $(home)/BLAS LAPACKdir = $(home)/LAPACK UTILdir = $(home)/UTIL SRCdir = $(home)/SRC # DIRS = $(BLASdir) $(LAPACKdir) $(UTILdir) $(SRCdir) # # %-------------------------------------------------------------------% # | Comment out the previous line and uncomment the following | # | if you already have the BLAS and LAPACK installed on your system. | # | NOTE: ARPACK assumes the use of LAPACK version 2 codes. | # %-------------------------------------------------------------------% # #DIRS = $(UTILdir) $(SRCdir) # # %---------------------------------------------------% # | The name of the libraries to be created/linked to | # %---------------------------------------------------% # ARPACKLIB = $(home)/libarpack_$(PLAT).a LAPACKLIB = BLASLIB = ALIBS = $(ARPACKLIB) $(LAPACKLIB) $(BLASLIB) # # # %---------------------------------------------------------% # | SECTION 2: COMPILERS | # | | # | The following macros specify compilers, linker/loaders, | # | the archiver, and their options. You need to make sure | # | these are correct for your system. | # %---------------------------------------------------------% # # # %------------------------------% # | Make our own suffixes' list. | # %------------------------------% # .SUFFIXES: .SUFFIXES: .f .o # # %------------------% # | Default command. | # %------------------% # .DEFAULT: @$(ECHO) "Unknown target $@, try: make help" # # %-------------------------------------------% # | Command to build .o files from .f files. | # %-------------------------------------------% # .f.o: @$(ECHO) Making $@ from $< @$(FC) -c $(FFLAGS) $< # # %-----------------------------------------% # | Various compilation programs and flags. | # | You need to make sure these are correct | # | for your system. | # %-----------------------------------------% # FC = f77 FFLAGS = -O2 LDFLAGS = CD = cd ECHO = echo LN = ln LNFLAGS = -s MAKE = /bin/make RM = rm RMFLAGS = -f SHELL = /bin/sh # # %--------------------------------------------% # | For System V based machine without ranlib, | # | like Cray and SGI, use touch instead. | # %--------------------------------------------% # AR = ar ARFLAGS = rv RANLIB = touch #RANLIB = ranlib # # %----------------------------------% # | This is the general help target. | # %----------------------------------% # help: @$(ECHO) "usage: make ?" arpack-akloeckner-07/ARMAKES/ARmake.SUN40000644000175000017500000000742706141016671017405 0ustar andreasandreas########################################################################### # # Program: ARPACK # # Module: ARmake.inc # # Purpose: Top-level Definitions # # Creation date: February 22, 1996 # # Modified: # # Send bug reports, comments or suggestions to arpack@caam.rice.edu # ############################################################################ # # %---------------------------------% # | SECTION 1: PATHS AND LIBRARIES | # %---------------------------------% # # # %--------------------------------------% # | You should change the definition of | # | home if ARPACK is built some place | # | other than your home directory. | # %--------------------------------------% # home = $(HOME)/ARPACK # # %--------------------------------------% # | The platform identifier to suffix to | # | the end of library names | # %--------------------------------------% # PLAT = SUN4 # # %------------------------------------------------------% # | The directories to find the various pieces of ARPACK | # %------------------------------------------------------% # BLASdir = $(home)/BLAS LAPACKdir = $(home)/LAPACK UTILdir = $(home)/UTIL SRCdir = $(home)/SRC # DIRS = $(BLASdir) $(LAPACKdir) $(UTILdir) $(SRCdir) # # %-------------------------------------------------------------------% # | Comment out the previous line and uncomment the following | # | if you already have the BLAS and LAPACK installed on your system. | # | NOTE: ARPACK assumes the use of LAPACK version 2 codes. | # %-------------------------------------------------------------------% # #DIRS = $(UTILdir) $(SRCdir) # # %---------------------------------------------------% # | The name of the libraries to be created/linked to | # %---------------------------------------------------% # ARPACKLIB = $(home)/libarpack_$(PLAT).a LAPACKLIB = BLASLIB = # ALIBS = $(ARPACKLIB) $(LAPACKLIB) $(BLASLIB) # # # %---------------------------------------------------------% # | SECTION 2: COMPILERS | # | | # | The following macros specify compilers, linker/loaders, | # | the archiver, and their options. You need to make sure | # | these are correct for your system. | # %---------------------------------------------------------% # # # %------------------------------% # | Make our own suffixes' list. | # %------------------------------% # .SUFFIXES: .SUFFIXES: .f .o # # %------------------% # | Default command. | # %------------------% # .DEFAULT: @$(ECHO) "Unknown target $@, try: make help" # # %-------------------------------------------% # | Command to build .o files from .f files. | # %-------------------------------------------% # .f.o: @$(ECHO) Making $@ from $< @$(FC) -c $(FFLAGS) $< # # %-----------------------------------------% # | Various compilation programs and flags. | # | You need to make sure these are correct | # | for your system. | # %-----------------------------------------% # FC = f77 FFLAGS = -O -cg89 LDFLAGS = CD = cd ECHO = echo LN = ln LNFLAGS = -s MAKE = /bin/make RM = rm RMFLAGS = -f SHELL = /bin/sh # # %----------------------------------------------------------------% # | The archiver and the flag(s) to use when building an archive | # | (library). Also the ranlib routine. If your system has no | # | ranlib, set RANLIB = touch. | # %----------------------------------------------------------------% # AR = ar ARFLAGS = rv #RANLIB = touch RANLIB = ranlib # # %----------------------------------% # | This is the general help target. | # %----------------------------------% # help: @$(ECHO) "usage: make ?" arpack-akloeckner-07/ARMAKES/ARmake.SP20000644000175000017500000000453006215635506017256 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: ARmake.inc # # Purpose: Top-level Definitions # # Creation date: February 22, 1996 # # Modified: # # Send bug reports, comments or suggestions to arpack@caam.rice.edu # ############################################################################ # # The complete path to the top level of ARPACK directory, usually # $(HOME)/ARPACK # home = $(HOME)/ARPACK # # The platform identifier to suffix to the end of library names # PLAT = SP2 # # The directories to find the various pieces of ARPACK # BLASdir = $(home)/BLAS LAPACKdir = $(home)/LAPACK UTILdir = $(home)/UTIL SRCdir = $(home)/SRC # DIRS = $(BLASdir) $(LAPACKdir) $(UTILdir) $(SRCdir) # Comment out the previous line and uncomment the following # if you already have the BLAS and LAPACK installed on your system. # NOTE: ARPACK assumes the use of LAPACK version 2 codes. #DIRS = $(LAPACKdir) $(UTILdir) $(SRCdir) # # # The name of the libraries to be created/linked to # ARPACKLIB = $(home)/libarpack_$(PLAT).a LAPACKLIB = BLASLIB = -lesslp2 ALIBS = $(ARPACKLIB) $(LAPACKLIB) $(BLASLIB) # # Make our own suffixes' list. # .SUFFIXES: .SUFFIXES: .f .o .SUFFIXES: .F .f # # Default command. # .DEFAULT: @$(ECHO) "Unknown target $@, try: make help" # # Command to build .o files from .f files. # .f.o: @$(ECHO) Making $@ from $< @$(FC) -c $(FFLAGS) $< .F.f: @$(ECHO) Making $*.f from $< @$(CPP) -P -DSINGLE $(CPPFLAGS) $< $*.f @$(ECHO) Making d$*.f from $< @$(CPP) -P -DDOUBLE $(CPPFLAGS) $< d$*.f # # Various compilation programs and flags. # You need to make sure these are correct for your system. # FC = xlf FFLAGS = -O2 LDFLAGS = CD = cd CHMOD = chmod CHFLAGS = -f COMPRESS = compress CP = cp # To find the path for cpp, try `man cpp', and it should list the path # at the top, under `Syntax'. It is usually in /lib. CPP = /lib/cpp CPPFLAGS = ECHO = echo LN = ln LNFLAGS = -s MAKE = /bin/make MKDIR = mkdir MDFLAGS = -p MV = mv MVFLAGS = -f RM = rm RMFLAGS = -f SHELL = /bin/sh TAR = tar # For System V based machine without ranlib, like Cray and SGI, # use touch instead. #RANLIB = touch RANLIB = ranlib # # This is the general help target. # help: @$(ECHO) "usage: make ?" arpack-akloeckner-07/README0000644000175000017500000001004207542136673015365 0ustar andreasandreas1. You have successfully unbundled ARPACK and are now in the ARPACK directory that was created for you. 2. Recent bug fixes are included in patch.tar.gz and ppatch.tar.gz (only needed if you are using PARPACK also.) If you have not retrieved these files, please do so and place them in the directory right above the current directory. (They should be in the same directory where arpack96.tar reside). Use uncompress or gunzip to unzip the tar files, and use 'tar -xvf ' to unbundle these patches. The source codes in these patches will overwrite those contained in arpack96.tar and parpack96.tar. 3. Upon executing the 'ls | more ' command you should see BLAS DOCUMENTS EXAMPLES LAPACK README SRC UTIL Makefile ARmake.inc ARMAKES The following entries are directories: ARMAKES, BLAS, DOCUMENTS, EXAMPLES, LAPACK, SRC, UTIL The directory SRC contains the top level routines including the highest level reverse communication interface routines ssaupd, dsaupd - symmetric single and double precision snaupd, dnaupd - non-symmetric single and double precision cnaupd, cnaupd - complex non-symmetric single and double precision The headers of these routines contain full documentation of calling sequence and usage. Additional information is in the DOCUMENTS directory. 4. Example driver programs that illustrate all the computational modes, data types and precisions may be found in the EXAMPLES directory. Upon executing the 'ls EXAMPLES | more ' command you should see BAND COMPLEX NONSYM README SIMPLE SVD SYM Example programs for banded, complex, nonsymmetric, symmetric, and singular value decomposition may be found in the directories BAND, COMPLEX, NONSYM, SYM, SVD respectively. Look at the README file for further information. To get started, get into the SIMPLE directory to see example programs that illustrate the use of ARPACK in the simplest modes of operation for the most commonly posed standard eigenvalue problems. The following instructions explain how to make the ARPACK library. 5. Before you can compile anything, you must first edit and correct the file ARmake.inc. Sample ARmake.inc's can be found in the ARMAKES directory. Edit "ARmake.inc" and change the definition "home" to the root of the source tree (Top level of ARPACK directory) The makefile is set up to build a self-contained library which includes the needed BLAS 1/2/3 and LAPACK routines. If you already have the BLAS and LAPACK libraries installed on your system you might want to change the definition of DIRS as indicated in the ARmake.inc file. *** NOTE *** Unless the LAPACK library on your system is version 2.0, we strongly recommend that you install the LAPACK routines provided with ARPACK. Note that the current LAPACK release is version 3.0; if you are not sure which version of LAPACK is installed, pleaase compile and link to the subset of LAPACK included with ARPACK. 6. You will also need to change the file "second.f" in the UTIL directory to whatever is appropriate for timing on your system. The "second" routine provided works on most workstations. If you are running on a Cray, you can just edit the makefile in UTIL and take out the reference to "second.o" to use the system second routine. 7. Do "make lib" in the current directory to build the standard library "libarpack_$(PLAT).a" 8. Within DOCUMENTS directory there are three files ex-sym.doc ex-nonsym.doc and ex-complex.doc for templates on how to invoke the computational modes of ARPACK. Also look in the README file for explanations concerning the other documents. Danny Sorensen at sorensen@caam.rice.edu Richard Lehoucq at rblehou@sandia.gov Chao Yang at cyang@lbl.gov Kristi Maschhoff at kristyn@tera.com If you have questions regarding using ARPACK, please send email to arpack@caam.rice.edu. Good luck and enjoy. arpack-akloeckner-07/ARmake.inc0000644000175000017500000000743010670624413016335 0ustar andreasandreas########################################################################### # # Program: ARPACK # # Module: ARmake.inc # # Purpose: Top-level Definitions # # Creation date: February 22, 1996 # # Modified: # # Send bug reports, comments or suggestions to arpack@caam.rice.edu # ############################################################################ # # %---------------------------------% # | SECTION 1: PATHS AND LIBRARIES | # %---------------------------------% # # # %--------------------------------------% # | You should change the definition of | # | home if ARPACK is built some place | # | other than your home directory. | # %--------------------------------------% # export home ?= $(shell pwd) # # %--------------------------------------% # | The platform identifier to suffix to | # | the end of library names | # %--------------------------------------% # PLAT = LINUX # # %------------------------------------------------------% # | The directories to find the various pieces of ARPACK | # %------------------------------------------------------% # BLASdir = $(home)/BLAS LAPACKdir = $(home)/LAPACK UTILdir = $(home)/UTIL SRCdir = $(home)/SRC # #DIRS = $(BLASdir) $(LAPACKdir) $(UTILdir) $(SRCdir) # # %-------------------------------------------------------------------% # | Comment out the previous line and uncomment the following | # | if you already have the BLAS and LAPACK installed on your system. | # | NOTE: ARPACK assumes the use of LAPACK version 2 codes. | # %-------------------------------------------------------------------% # DIRS = $(UTILdir) $(SRCdir) # # %---------------------------------------------------% # | The name of the libraries to be created/linked to | # %---------------------------------------------------% # ARPACKLIB = $(home)/libarpack.a LAPACKLIB = BLASLIB = # ALIBS = $(ARPACKLIB) $(LAPACKLIB) $(BLASLIB) # # # %---------------------------------------------------------% # | SECTION 2: COMPILERS | # | | # | The following macros specify compilers, linker/loaders, | # | the archiver, and their options. You need to make sure | # | these are correct for your system. | # %---------------------------------------------------------% # # # %------------------------------% # | Make our own suffixes' list. | # %------------------------------% # .SUFFIXES: .SUFFIXES: .f .o # # %------------------% # | Default command. | # %------------------% # .DEFAULT: @$(ECHO) "Unknown target $@, try: make help" # # %-------------------------------------------% # | Command to build .o files from .f files. | # %-------------------------------------------% # .f.o: @$(ECHO) Making $@ from $< @$(FC) -c $(FFLAGS) $< # # %-----------------------------------------% # | Various compilation programs and flags. | # | You need to make sure these are correct | # | for your system. | # %-----------------------------------------% # FC = f77 FFLAGS = -O3 -fPIC LDFLAGS = CD = cd ECHO = echo LN = ln LNFLAGS = -s #MAKE = /bin/make RM = rm RMFLAGS = -f SHELL = /bin/sh # # %----------------------------------------------------------------% # | The archiver and the flag(s) to use when building an archive | # | (library). Also the ranlib routine. If your system has no | # | ranlib, set RANLIB = touch. | # %----------------------------------------------------------------% # AR = ar ARFLAGS = rv #RANLIB = touch RANLIB = ranlib # # %----------------------------------% # | This is the general help target. | # %----------------------------------% # help: @$(ECHO) "usage: make ?" arpack-akloeckner-07/BLAS/0000755000175000017500000000000006215034670015217 5ustar andreasandreasarpack-akloeckner-07/BLAS/dasum.f0000644000175000017500000000211406034032721016467 0ustar andreasandreas double precision function dasum(n,dx,incx) c c takes the sum of the absolute values. c uses unrolled loops for increment equal to one. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c double precision dx(1),dtemp integer i,incx,ix,m,mp1,n c dasum = 0.0d0 dtemp = 0.0d0 if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n dtemp = dtemp + dabs(dx(ix)) ix = ix + incx 10 continue dasum = 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 dasum = dtemp return end arpack-akloeckner-07/BLAS/daxpy.f0000644000175000017500000000220506034032721016504 0ustar andreasandreas subroutine daxpy(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 double precision dx(1),dy(1),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 arpack-akloeckner-07/BLAS/dcopy.f0000644000175000017500000000215006034032721016474 0ustar andreasandreas subroutine dcopy(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 double precision dx(1),dy(1) 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 arpack-akloeckner-07/BLAS/ddot.f0000644000175000017500000000224306034032721016313 0ustar andreasandreas double precision function ddot(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 double precision dx(1),dy(1),dtemp integer i,incx,incy,ix,iy,m,mp1,n c ddot = 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 ddot = 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 ddot = dtemp return end arpack-akloeckner-07/BLAS/dgemm.f0000644000175000017500000002317306034032722016460 0ustar andreasandreas SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. 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. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = A'. * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = '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 TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * 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 .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * transposed and set NROWA, NCOLA and NROWB as the number of rows * and columns of A and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And if alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K 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 arpack-akloeckner-07/BLAS/dgemv.f0000644000175000017500000001647106034032722016474 0ustar andreasandreas SUBROUTINE DGEMV ( 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 .. EXTERNAL XERBLA * .. 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 IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMV ', 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 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 arpack-akloeckner-07/BLAS/dger.f0000644000175000017500000001041606034032722016304 0ustar andreasandreas SUBROUTINE DGER ( 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 arpack-akloeckner-07/BLAS/dnrm2.f0000644000175000017500000000774506034032722016420 0ustar andreasandreas double precision function dnrm2 ( n, dx, incx) integer i, incx, ix, j, n, next double precision dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one data zero, one /0.0d0, 1.0d0/ c c euclidean norm of the n-vector stored in dx() with storage c increment incx . c if n .le. 0 return with result = 0. c if n .ge. 1 then incx must be .ge. 1 c c c.l.lawson, 1978 jan 08 c modified to correct problem with negative increment, 8/21/90. c c four phase method using two built-in constants that are c hopefully applicable to all machines. c cutlo = maximum of dsqrt(u/eps) over all known machines. c cuthi = minimum of dsqrt(v) over all known machines. c where c eps = smallest no. such that eps + 1. .gt. 1. c u = smallest positive no. (underflow limit) c v = largest no. (overflow limit) c c brief outline of algorithm.. c c phase 1 scans zero components. c move to phase 2 when a component is nonzero and .le. cutlo c move to phase 3 when a component is .gt. cutlo c move to phase 4 when a component is .ge. cuthi/m c where m = n for x() real and m = 2*n for complex. c c values for cutlo and cuthi.. c from the environmental parameters listed in the imsl converter c document the limiting values are as follows.. c cutlo, s.p. u/eps = 2**(-102) for honeywell. close seconds are c univac and dec at 2**(-103) c thus cutlo = 2**(-51) = 4.44089e-16 c cuthi, s.p. v = 2**127 for univac, honeywell, and dec. c thus cuthi = 2**(63.5) = 1.30438e19 c cutlo, d.p. u/eps = 2**(-67) for honeywell and dec. c thus cutlo = 2**(-33.5) = 8.23181d-11 c cuthi, d.p. same as s.p. cuthi = 1.30438d19 c data cutlo, cuthi / 8.232d-11, 1.304d19 / c data cutlo, cuthi / 4.441e-16, 1.304e19 / c data cutlo, cuthi / 8.232d-11, 1.304d19 / c.... from Ed Anderson data cutlo / 0.1415686533102923D-145 / data cuthi / 0.1340780792994260D+155 / c if(n .gt. 0) go to 10 dnrm2 = zero go to 300 c 10 assign 30 to next sum = zero i = 1 if( incx .lt. 0 )i = (-n+1)*incx + 1 ix = 1 c begin main loop 20 go to next,(30, 50, 70, 110) 30 if( dabs(dx(i)) .gt. cutlo) go to 85 assign 50 to next xmax = zero c c phase 1. sum is zero c 50 if( dx(i) .eq. zero) go to 200 if( dabs(dx(i)) .gt. cutlo) go to 85 c c prepare for phase 2. assign 70 to next go to 105 c c prepare for phase 4. c 100 continue assign 110 to next sum = (sum / dx(i)) / dx(i) 105 xmax = dabs(dx(i)) go to 115 c c phase 2. sum is small. c scale to avoid destructive underflow. c 70 if( dabs(dx(i)) .gt. cutlo ) go to 75 c c common code for phases 2 and 4. c in phase 4 sum is large. scale to avoid overflow. c 110 if( dabs(dx(i)) .le. xmax ) go to 115 sum = one + sum * (xmax / dx(i))**2 xmax = dabs(dx(i)) go to 200 c 115 sum = sum + (dx(i)/xmax)**2 go to 200 c c c prepare for phase 3. c 75 sum = (sum * xmax) * xmax c c c for real or d.p. set hitest = cuthi/n c for complex set hitest = cuthi/(2*n) c 85 hitest = cuthi/float( n ) c c phase 3. sum is mid-range. no scaling. c do 95 j = ix,n if(dabs(dx(i)) .ge. hitest) go to 100 sum = sum + dx(i)**2 i = i + incx 95 continue dnrm2 = dsqrt( sum ) go to 300 c 200 continue ix = ix + 1 i = i + incx if( ix .le. n ) go to 20 c c end of main loop. c c compute square root and adjust for scaling. c dnrm2 = xmax * dsqrt(sum) 300 continue return end arpack-akloeckner-07/BLAS/drot.f0000644000175000017500000000151506034032722016333 0ustar andreasandreas subroutine drot (n,dx,incx,dy,incy,c,s) c c applies a plane rotation. c jack dongarra, linpack, 3/11/78. c double precision dx(1),dy(1),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 arpack-akloeckner-07/BLAS/drotg.f0000644000175000017500000000124206034032722016477 0ustar andreasandreas subroutine drotg(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 arpack-akloeckner-07/BLAS/dscal.f0000644000175000017500000000174706034032722016460 0ustar andreasandreas subroutine dscal(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 to correct problem with negative increment, 8/21/90. c double precision da,dx(1) integer i,incx,ix,m,mp1,n c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n dx(ix) = da*dx(ix) ix = ix + incx 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 arpack-akloeckner-07/BLAS/dswap.f0000644000175000017500000000232406034032722016500 0ustar andreasandreas subroutine dswap (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 double precision dx(1),dy(1),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 arpack-akloeckner-07/BLAS/dsymv.f0000644000175000017500000001761006034032722016530 0ustar andreasandreas SUBROUTINE DSYMV ( 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 arpack-akloeckner-07/BLAS/dsyr2.f0000644000175000017500000001625606034032722016436 0ustar andreasandreas SUBROUTINE DSYR2 ( 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 arpack-akloeckner-07/BLAS/dtrsm.f0000644000175000017500000002777106034032723016531 0ustar andreasandreas SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DTRSM solves one of the matrix equations * * op( A )*X = alpha*B, or X*op( A ) = alpha*B, * * where alpha is a scalar, X and B are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * The matrix X is overwritten on B. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*B. * * SIDE = 'R' or 'r' X*op( A ) = alpha*B. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the right-hand side matrix B, and on exit is * overwritten by the solution matrix X. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) * INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRSM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*inv( A )*B. * IF( UPPER )THEN DO 60, J = 1, N IF( ALPHA.NE.ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE END IF DO 50, K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE END IF 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N IF( ALPHA.NE.ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE END IF DO 90 K = 1, M IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE END IF 90 CONTINUE 100 CONTINUE END IF ELSE * * Form B := alpha*inv( A' )*B. * IF( UPPER )THEN DO 130, J = 1, N DO 120, I = 1, M TEMP = ALPHA*B( I, J ) DO 110, K = 1, I - 1 TEMP = TEMP - A( K, I )*B( K, J ) 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 120 CONTINUE 130 CONTINUE ELSE DO 160, J = 1, N DO 150, I = M, 1, -1 TEMP = ALPHA*B( I, J ) DO 140, K = I + 1, M TEMP = TEMP - A( K, I )*B( K, J ) 140 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 150 CONTINUE 160 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*B*inv( A ). * IF( UPPER )THEN DO 210, J = 1, N IF( ALPHA.NE.ONE )THEN DO 170, I = 1, M B( I, J ) = ALPHA*B( I, J ) 170 CONTINUE END IF DO 190, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN DO 180, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 180 CONTINUE END IF 190 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 200, I = 1, M B( I, J ) = TEMP*B( I, J ) 200 CONTINUE END IF 210 CONTINUE ELSE DO 260, J = N, 1, -1 IF( ALPHA.NE.ONE )THEN DO 220, I = 1, M B( I, J ) = ALPHA*B( I, J ) 220 CONTINUE END IF DO 240, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN DO 230, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 230 CONTINUE END IF 240 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 250, I = 1, M B( I, J ) = TEMP*B( I, J ) 250 CONTINUE END IF 260 CONTINUE END IF ELSE * * Form B := alpha*B*inv( A' ). * IF( UPPER )THEN DO 310, K = N, 1, -1 IF( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 270, I = 1, M B( I, K ) = TEMP*B( I, K ) 270 CONTINUE END IF DO 290, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = A( J, K ) DO 280, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 280 CONTINUE END IF 290 CONTINUE IF( ALPHA.NE.ONE )THEN DO 300, I = 1, M B( I, K ) = ALPHA*B( I, K ) 300 CONTINUE END IF 310 CONTINUE ELSE DO 360, K = 1, N IF( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 320, I = 1, M B( I, K ) = TEMP*B( I, K ) 320 CONTINUE END IF DO 340, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = A( J, K ) DO 330, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 330 CONTINUE END IF 340 CONTINUE IF( ALPHA.NE.ONE )THEN DO 350, I = 1, M B( I, K ) = ALPHA*B( I, K ) 350 CONTINUE END IF 360 CONTINUE END IF END IF END IF * RETURN * * End of DTRSM . * END arpack-akloeckner-07/BLAS/idamax.f0000644000175000017500000000162206034032723016626 0ustar andreasandreas integer function idamax(n,dx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c double precision dx(1),dmax integer i,incx,ix,n c idamax = 0 if( n .lt. 1 ) return idamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 dmax = dabs(dx(ix)) ix = ix + incx do 10 i = 2,n if(dabs(dx(ix)).le.dmax) go to 5 idamax = i dmax = dabs(dx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 dmax = dabs(dx(1)) do 30 i = 2,n if(dabs(dx(i)).le.dmax) go to 30 idamax = i dmax = dabs(dx(i)) 30 continue return end arpack-akloeckner-07/BLAS/isamax.f0000644000175000017500000000160006034032723016641 0ustar andreasandreas integer function isamax(n,sx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c real sx(1),smax integer i,incx,ix,n c isamax = 0 if( n .lt. 1 ) return isamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 smax = abs(sx(ix)) ix = ix + incx do 10 i = 2,n if(abs(sx(ix)).le.smax) go to 5 isamax = i smax = abs(sx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 smax = abs(sx(1)) do 30 i = 2,n if(abs(sx(i)).le.smax) go to 30 isamax = i smax = abs(sx(i)) 30 continue return end arpack-akloeckner-07/BLAS/sasum.f0000644000175000017500000000205406034032723016513 0ustar andreasandreas real function sasum(n,sx,incx) c c takes the sum of the absolute values. c uses unrolled loops for increment equal to one. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c real sx(1),stemp integer i,incx,ix,m,mp1,n c sasum = 0.0e0 stemp = 0.0e0 if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n stemp = stemp + abs(sx(ix)) ix = ix + incx 10 continue sasum = stemp return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,6) if( m .eq. 0 ) go to 40 do 30 i = 1,m stemp = stemp + abs(sx(i)) 30 continue if( n .lt. 6 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,6 stemp = stemp + abs(sx(i)) + abs(sx(i + 1)) + abs(sx(i + 2)) * + abs(sx(i + 3)) + abs(sx(i + 4)) + abs(sx(i + 5)) 50 continue 60 sasum = stemp return end arpack-akloeckner-07/BLAS/saxpy.f0000644000175000017500000000216606034032723016533 0ustar andreasandreas subroutine saxpy(n,sa,sx,incx,sy,incy) c c constant times a vector plus a vector. c uses unrolled loop for increments equal to one. c jack dongarra, linpack, 3/11/78. c real sx(1),sy(1),sa integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (sa .eq. 0.0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n sy(iy) = sy(iy) + sa*sx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m sy(i) = sy(i) + sa*sx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 sy(i) = sy(i) + sa*sx(i) sy(i + 1) = sy(i + 1) + sa*sx(i + 1) sy(i + 2) = sy(i + 2) + sa*sx(i + 2) sy(i + 3) = sy(i + 3) + sa*sx(i + 3) 50 continue return end arpack-akloeckner-07/BLAS/scopy.f0000644000175000017500000000213106034032723016514 0ustar andreasandreas subroutine scopy(n,sx,incx,sy,incy) c c copies a vector, x, to a vector, y. c uses unrolled loops for increments equal to 1. c jack dongarra, linpack, 3/11/78. c real sx(1),sy(1) integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n sy(iy) = sx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,7) if( m .eq. 0 ) go to 40 do 30 i = 1,m sy(i) = sx(i) 30 continue if( n .lt. 7 ) return 40 mp1 = m + 1 do 50 i = mp1,n,7 sy(i) = sx(i) sy(i + 1) = sx(i + 1) sy(i + 2) = sx(i + 2) sy(i + 3) = sx(i + 3) sy(i + 4) = sx(i + 4) sy(i + 5) = sx(i + 5) sy(i + 6) = sx(i + 6) 50 continue return end arpack-akloeckner-07/BLAS/sdot.f0000644000175000017500000000221306034032723016331 0ustar andreasandreas real function sdot(n,sx,incx,sy,incy) c c forms the dot product of two vectors. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c real sx(1),sy(1),stemp integer i,incx,incy,ix,iy,m,mp1,n c stemp = 0.0e0 sdot = 0.0e0 if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n stemp = stemp + sx(ix)*sy(iy) ix = ix + incx iy = iy + incy 10 continue sdot = stemp return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m stemp = stemp + sx(i)*sy(i) 30 continue if( n .lt. 5 ) go to 60 40 mp1 = m + 1 do 50 i = mp1,n,5 stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) + * sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4) 50 continue 60 sdot = stemp return end arpack-akloeckner-07/BLAS/sgemm.f0000644000175000017500000002317306034032723016500 0ustar andreasandreas SUBROUTINE SGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC REAL ALPHA, BETA * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * SGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X', * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = A'. * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = B'. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB REAL TEMP * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * transposed and set NROWA, NCOLA and NROWB as the number of rows * and columns of A and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And if alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF( NOTA )THEN * * Form C := alpha*A*B' + beta*C * DO 170, J = 1, N IF( BETA.EQ.ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE END IF DO 160, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE END IF 160 CONTINUE 170 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 190 CONTINUE 200 CONTINUE END IF END IF * RETURN * * End of SGEMM . * END arpack-akloeckner-07/BLAS/sgemv.f0000644000175000017500000001647106034032723016514 0ustar andreasandreas SUBROUTINE SGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * SGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * X - REAL array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - REAL array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. 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 IF( INFO.NE.0 )THEN CALL XERBLA( 'SGEMV ', 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 A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = ZERO DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX DO 110, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE END IF END IF * RETURN * * End of SGEMV . * END arpack-akloeckner-07/BLAS/sger.f0000644000175000017500000001041606034032723016324 0ustar andreasandreas SUBROUTINE SGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. REAL ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * SGER performs the rank 1 operation * * A := alpha*x*y' + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGER ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of SGER . * END arpack-akloeckner-07/BLAS/snrm2.f0000644000175000017500000001007206034032724016424 0ustar andreasandreas real function snrm2 ( n, sx, incx) integer i, incx, ix, j, n, next real sx(1), cutlo, cuthi, hitest, sum, xmax, zero, one data zero, one /0.0e0, 1.0e0/ c c euclidean norm of the n-vector stored in sx() with storage c increment incx . c if n .le. 0 return with result = 0. c if n .ge. 1 then incx must be .ge. 1 c c c.l.lawson, 1978 jan 08 c modified to correct problem with negative increment, 8/21/90. c c four phase method using two built-in constants that are c hopefully applicable to all machines. c cutlo = maximum of sqrt(u/eps) over all known machines. c cuthi = minimum of sqrt(v) over all known machines. c where c eps = smallest no. such that eps + 1. .gt. 1. c u = smallest positive no. (underflow limit) c v = largest no. (overflow limit) c c brief outline of algorithm.. c c phase 1 scans zero components. c move to phase 2 when a component is nonzero and .le. cutlo c move to phase 3 when a component is .gt. cutlo c move to phase 4 when a component is .ge. cuthi/m c where m = n for x() real and m = 2*n for complex. c c values for cutlo and cuthi.. c from the environmental parameters listed in the imsl converter c document the limiting values are as follows.. c cutlo, s.p. u/eps = 2**(-102) for honeywell. close seconds are c univac and dec at 2**(-103) c thus cutlo = 2**(-51) = 4.44089e-16 c cuthi, s.p. v = 2**127 for univac, honeywell, and dec. c thus cuthi = 2**(63.5) = 1.30438e19 c cutlo, d.p. u/eps = 2**(-67) for honeywell and dec. c thus cutlo = 2**(-33.5) = 8.23181d-11 c cuthi, d.p. same as s.p. cuthi = 1.30438d19 c data cutlo, cuthi / 8.232d-11, 1.304d19 / c data cutlo, cuthi / 4.441e-16, 1.304e19 / c data cutlo, cuthi / 4.441e-16, 1.304e19 / c... from Ed Anderson (for Cray) c data cutlo / 0300315520236314774737b / c data cuthi / 0500004000000000000000b / c... from Ed Anderson (for Sun4) data cutlo / 0.44408921E-15 / data cuthi / 0.18446743E+20 / c if(n .gt. 0) go to 10 snrm2 = zero go to 300 c 10 assign 30 to next sum = zero i = 1 if(incx.lt.0)i = (-n+1)*incx + 1 ix = 1 c begin main loop 20 go to next,(30, 50, 70, 110) 30 if( abs(sx(i)) .gt. cutlo) go to 85 assign 50 to next xmax = zero c c phase 1. sum is zero c 50 if( sx(i) .eq. zero) go to 200 if( abs(sx(i)) .gt. cutlo) go to 85 c c prepare for phase 2. assign 70 to next go to 105 c c prepare for phase 4. c 100 continue assign 110 to next sum = (sum / sx(i)) / sx(i) 105 xmax = abs(sx(i)) go to 115 c c phase 2. sum is small. c scale to avoid destructive underflow. c 70 if( abs(sx(i)) .gt. cutlo ) go to 75 c c common code for phases 2 and 4. c in phase 4 sum is large. scale to avoid overflow. c 110 if( abs(sx(i)) .le. xmax ) go to 115 sum = one + sum * (xmax / sx(i))**2 xmax = abs(sx(i)) go to 200 c 115 sum = sum + (sx(i)/xmax)**2 go to 200 c c c prepare for phase 3. c 75 sum = (sum * xmax) * xmax c c c for real or d.p. set hitest = cuthi/n c for complex set hitest = cuthi/(2*n) c 85 hitest = cuthi/float( n ) c c phase 3. sum is mid-range. no scaling. c do 95 j = ix, n if(abs(sx(i)) .ge. hitest) go to 100 sum = sum + sx(i)**2 i = i + incx 95 continue snrm2 = sqrt( sum ) go to 300 c 200 continue ix = ix + 1 i = i + incx if( ix .le. n ) go to 20 c c end of main loop. c c compute square root and adjust for scaling. c snrm2 = xmax * sqrt(sum) 300 continue return end arpack-akloeckner-07/BLAS/srot.f0000644000175000017500000000150006034032724016346 0ustar andreasandreas subroutine srot (n,sx,incx,sy,incy,c,s) c c applies a plane rotation. c jack dongarra, linpack, 3/11/78. c real sx(1),sy(1),stemp,c,s integer i,incx,incy,ix,iy,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n stemp = c*sx(ix) + s*sy(iy) sy(iy) = c*sy(iy) - s*sx(ix) sx(ix) = stemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n stemp = c*sx(i) + s*sy(i) sy(i) = c*sy(i) - s*sx(i) sx(i) = stemp 30 continue return end arpack-akloeckner-07/BLAS/srotg.f0000644000175000017500000000117206034032724016522 0ustar andreasandreas subroutine srotg(sa,sb,c,s) c c construct givens plane rotation. c jack dongarra, linpack, 3/11/78. c real sa,sb,c,s,roe,scale,r,z c roe = sb if( abs(sa) .gt. abs(sb) ) roe = sa scale = abs(sa) + abs(sb) if( scale .ne. 0.0 ) go to 10 c = 1.0 s = 0.0 r = 0.0 z = 0.0 go to 20 10 r = scale*sqrt((sa/scale)**2 + (sb/scale)**2) r = sign(1.0,roe)*r c = sa/r s = sb/r z = 1.0 if( abs(sa) .gt. abs(sb) ) z = s if( abs(sb) .ge. abs(sa) .and. c .ne. 0.0 ) z = 1.0/c 20 sa = r sb = z return end arpack-akloeckner-07/BLAS/sscal.f0000644000175000017500000000173406034032724016475 0ustar andreasandreas subroutine sscal(n,sa,sx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to 1. c jack dongarra, linpack, 3/11/78. c modified to correct problem with negative increment, 8/21/90. c real sa,sx(1) integer i,incx,ix,m,mp1,n c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 do 10 i = 1,n sx(ix) = sa*sx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m sx(i) = sa*sx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 sx(i) = sa*sx(i) sx(i + 1) = sa*sx(i + 1) sx(i + 2) = sa*sx(i + 2) sx(i + 3) = sa*sx(i + 3) sx(i + 4) = sa*sx(i + 4) 50 continue return end arpack-akloeckner-07/BLAS/sswap.f0000644000175000017500000000231006034032724016514 0ustar andreasandreas subroutine sswap (n,sx,incx,sy,incy) c c interchanges two vectors. c uses unrolled loops for increments equal to 1. c jack dongarra, linpack, 3/11/78. c real sx(1),sy(1),stemp integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n stemp = sx(ix) sx(ix) = sy(iy) sy(iy) = stemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,3) if( m .eq. 0 ) go to 40 do 30 i = 1,m stemp = sx(i) sx(i) = sy(i) sy(i) = stemp 30 continue if( n .lt. 3 ) return 40 mp1 = m + 1 do 50 i = mp1,n,3 stemp = sx(i) sx(i) = sy(i) sy(i) = stemp stemp = sx(i + 1) sx(i + 1) = sy(i + 1) sy(i + 1) = stemp stemp = sx(i + 2) sx(i + 2) = sy(i + 2) sy(i + 2) = stemp 50 continue return end arpack-akloeckner-07/BLAS/ssymv.f0000644000175000017500000001761006034032724016551 0ustar andreasandreas SUBROUTINE SSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, LDA, N CHARACTER*1 UPLO * .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * SSYMV performs the matrix-vector operation * * y := alpha*A*x + beta*y, * * where alpha and beta are scalars, x and y are n element vectors and * A is an n by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of A is not referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. On exit, Y is overwritten by the updated * vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 5 ELSE IF( INCX.EQ.0 )THEN INFO = 7 ELSE IF( INCY.EQ.0 )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SSYMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * Set up the start points in X and Y. * IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, N Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, N Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, N Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, N Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( UPLO, 'U' ) )THEN * * Form y when A is stored in upper triangle. * IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 60, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO DO 50, I = 1, J - 1 Y( I ) = Y( I ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( I ) 50 CONTINUE Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 60 CONTINUE ELSE JX = KX JY = KY DO 80, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO IX = KX IY = KY DO 70, I = 1, J - 1 Y( IY ) = Y( IY ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( IX ) IX = IX + INCX IY = IY + INCY 70 CONTINUE Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 80 CONTINUE END IF ELSE * * Form y when A is stored in lower triangle. * IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 100, J = 1, N TEMP1 = ALPHA*X( J ) TEMP2 = ZERO Y( J ) = Y( J ) + TEMP1*A( J, J ) DO 90, I = J + 1, N Y( I ) = Y( I ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( I ) 90 CONTINUE Y( J ) = Y( J ) + ALPHA*TEMP2 100 CONTINUE ELSE JX = KX JY = KY DO 120, J = 1, N TEMP1 = ALPHA*X( JX ) TEMP2 = ZERO Y( JY ) = Y( JY ) + TEMP1*A( J, J ) IX = JX IY = JY DO 110, I = J + 1, N IX = IX + INCX IY = IY + INCY Y( IY ) = Y( IY ) + TEMP1*A( I, J ) TEMP2 = TEMP2 + A( I, J )*X( IX ) 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP2 JX = JX + INCX JY = JY + INCY 120 CONTINUE END IF END IF * RETURN * * End of SSYMV . * END arpack-akloeckner-07/BLAS/ssyr2.f0000644000175000017500000001625606034032724016457 0ustar andreasandreas SUBROUTINE SSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. REAL ALPHA INTEGER INCX, INCY, LDA, N CHARACTER*1 UPLO * .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * SSYR2 performs the symmetric rank 2 operation * * A := alpha*x*y' + alpha*y*x' + A, * * where alpha is a scalar, x and y are n element vectors and A is an n * by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of A is not referenced. On exit, the * upper triangular part of the array A is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of A is not referenced. On exit, the * lower triangular part of the array A is overwritten by the * lower triangular part of the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP1, TEMP2 INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SSYR2 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Set up the start points in X and Y if the increments are not both * unity. * IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( N - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( N - 1 )*INCY END IF JX = KX JY = KY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * IF( LSAME( UPLO, 'U' ) )THEN * * Form A when A is stored in the upper triangle. * IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 20, J = 1, N IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) DO 10, I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 10 CONTINUE END IF 20 CONTINUE ELSE DO 40, J = 1, N IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = KX IY = KY DO 30, I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP1 $ + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 30 CONTINUE END IF JX = JX + INCX JY = JY + INCY 40 CONTINUE END IF ELSE * * Form A when A is stored in the lower triangle. * IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN DO 60, J = 1, N IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN TEMP1 = ALPHA*Y( J ) TEMP2 = ALPHA*X( J ) DO 50, I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 50 CONTINUE END IF 60 CONTINUE ELSE DO 80, J = 1, N IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN TEMP1 = ALPHA*Y( JY ) TEMP2 = ALPHA*X( JX ) IX = JX IY = JY DO 70, I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP1 $ + Y( IY )*TEMP2 IX = IX + INCX IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX JY = JY + INCY 80 CONTINUE END IF END IF * RETURN * * End of SSYR2 . * END arpack-akloeckner-07/BLAS/strsm.f0000644000175000017500000002777106034032724016551 0ustar andreasandreas SUBROUTINE STRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB REAL ALPHA * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * STRSM solves one of the matrix equations * * op( A )*X = alpha*B, or X*op( A ) = alpha*B, * * where alpha is a scalar, X and B are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * The matrix X is overwritten on B. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*B. * * SIDE = 'R' or 'r' X*op( A ) = alpha*B. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the right-hand side matrix B, and on exit is * overwritten by the solution matrix X. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA REAL TEMP * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) * INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'STRSM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*inv( A )*B. * IF( UPPER )THEN DO 60, J = 1, N IF( ALPHA.NE.ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE END IF DO 50, K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE END IF 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N IF( ALPHA.NE.ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE END IF DO 90 K = 1, M IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE END IF 90 CONTINUE 100 CONTINUE END IF ELSE * * Form B := alpha*inv( A' )*B. * IF( UPPER )THEN DO 130, J = 1, N DO 120, I = 1, M TEMP = ALPHA*B( I, J ) DO 110, K = 1, I - 1 TEMP = TEMP - A( K, I )*B( K, J ) 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 120 CONTINUE 130 CONTINUE ELSE DO 160, J = 1, N DO 150, I = M, 1, -1 TEMP = ALPHA*B( I, J ) DO 140, K = I + 1, M TEMP = TEMP - A( K, I )*B( K, J ) 140 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) B( I, J ) = TEMP 150 CONTINUE 160 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*B*inv( A ). * IF( UPPER )THEN DO 210, J = 1, N IF( ALPHA.NE.ONE )THEN DO 170, I = 1, M B( I, J ) = ALPHA*B( I, J ) 170 CONTINUE END IF DO 190, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN DO 180, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 180 CONTINUE END IF 190 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 200, I = 1, M B( I, J ) = TEMP*B( I, J ) 200 CONTINUE END IF 210 CONTINUE ELSE DO 260, J = N, 1, -1 IF( ALPHA.NE.ONE )THEN DO 220, I = 1, M B( I, J ) = ALPHA*B( I, J ) 220 CONTINUE END IF DO 240, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN DO 230, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 230 CONTINUE END IF 240 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 250, I = 1, M B( I, J ) = TEMP*B( I, J ) 250 CONTINUE END IF 260 CONTINUE END IF ELSE * * Form B := alpha*B*inv( A' ). * IF( UPPER )THEN DO 310, K = N, 1, -1 IF( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 270, I = 1, M B( I, K ) = TEMP*B( I, K ) 270 CONTINUE END IF DO 290, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = A( J, K ) DO 280, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 280 CONTINUE END IF 290 CONTINUE IF( ALPHA.NE.ONE )THEN DO 300, I = 1, M B( I, K ) = ALPHA*B( I, K ) 300 CONTINUE END IF 310 CONTINUE ELSE DO 360, K = 1, N IF( NOUNIT )THEN TEMP = ONE/A( K, K ) DO 320, I = 1, M B( I, K ) = TEMP*B( I, K ) 320 CONTINUE END IF DO 340, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = A( J, K ) DO 330, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 330 CONTINUE END IF 340 CONTINUE IF( ALPHA.NE.ONE )THEN DO 350, I = 1, M B( I, K ) = ALPHA*B( I, K ) 350 CONTINUE END IF 360 CONTINUE END IF END IF END IF * RETURN * * End of STRSM . * END arpack-akloeckner-07/BLAS/strmm.f0000644000175000017500000002632506034032724016535 0ustar andreasandreas SUBROUTINE STRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB REAL ALPHA * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * STRMM performs one of the matrix-matrix operations * * B := alpha*op( A )*B, or B := alpha*B*op( A ), * * where alpha is a scalar, B is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies B from * the left or right as follows: * * SIDE = 'L' or 'l' B := alpha*op( A )*B. * * SIDE = 'R' or 'r' B := alpha*B*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B, and on exit is overwritten by the * transformed matrix. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA REAL TEMP * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) * INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'STRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*A*B. * IF( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) B( K, J ) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP IF( NOUNIT ) $ B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE * * Form B := alpha*B*A'. * IF( UPPER )THEN DO 110, J = 1, N DO 100, I = M, 1, -1 TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE B( I, J ) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140, J = 1, N DO 130, I = 1, M TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 120, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 120 CONTINUE B( I, J ) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*B*A. * IF( UPPER )THEN DO 180, J = N, 1, -1 TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = 1, M B( I, J ) = TEMP*B( I, J ) 150 CONTINUE DO 170, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 160, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE ELSE DO 220, J = 1, N TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 190, I = 1, M B( I, J ) = TEMP*B( I, J ) 190 CONTINUE DO 210, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 200, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 200 CONTINUE END IF 210 CONTINUE 220 CONTINUE END IF ELSE * * Form B := alpha*B*A'. * IF( UPPER )THEN DO 260, K = 1, N DO 240, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 230, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 230 CONTINUE END IF 240 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 250, I = 1, M B( I, K ) = TEMP*B( I, K ) 250 CONTINUE END IF 260 CONTINUE ELSE DO 300, K = N, 1, -1 DO 280, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 270, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 270 CONTINUE END IF 280 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE END IF 300 CONTINUE END IF END IF END IF * RETURN * * End of STRMM . * END arpack-akloeckner-07/BLAS/dtrmm.f0000644000175000017500000002632506034032725016517 0ustar andreasandreas SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DTRMM performs one of the matrix-matrix operations * * B := alpha*op( A )*B, or B := alpha*B*op( A ), * * where alpha is a scalar, B is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies B from * the left or right as follows: * * SIDE = 'L' or 'l' B := alpha*op( A )*B. * * SIDE = 'R' or 'r' B := alpha*B*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B, and on exit is overwritten by the * transformed matrix. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL LSIDE, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOUNIT = LSAME( DIAG , 'N' ) UPPER = LSAME( UPLO , 'U' ) * INFO = 0 IF( ( .NOT.LSIDE ).AND. $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND. $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*A*B. * IF( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) B( K, J ) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP IF( NOUNIT ) $ B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE * * Form B := alpha*B*A'. * IF( UPPER )THEN DO 110, J = 1, N DO 100, I = M, 1, -1 TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE B( I, J ) = ALPHA*TEMP 100 CONTINUE 110 CONTINUE ELSE DO 140, J = 1, N DO 130, I = 1, M TEMP = B( I, J ) IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 120, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 120 CONTINUE B( I, J ) = ALPHA*TEMP 130 CONTINUE 140 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*B*A. * IF( UPPER )THEN DO 180, J = N, 1, -1 TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = 1, M B( I, J ) = TEMP*B( I, J ) 150 CONTINUE DO 170, K = 1, J - 1 IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 160, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 160 CONTINUE END IF 170 CONTINUE 180 CONTINUE ELSE DO 220, J = 1, N TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 190, I = 1, M B( I, J ) = TEMP*B( I, J ) 190 CONTINUE DO 210, K = J + 1, N IF( A( K, J ).NE.ZERO )THEN TEMP = ALPHA*A( K, J ) DO 200, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 200 CONTINUE END IF 210 CONTINUE 220 CONTINUE END IF ELSE * * Form B := alpha*B*A'. * IF( UPPER )THEN DO 260, K = 1, N DO 240, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 230, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 230 CONTINUE END IF 240 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 250, I = 1, M B( I, K ) = TEMP*B( I, K ) 250 CONTINUE END IF 260 CONTINUE ELSE DO 300, K = N, 1, -1 DO 280, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN TEMP = ALPHA*A( J, K ) DO 270, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 270 CONTINUE END IF 280 CONTINUE TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) IF( TEMP.NE.ONE )THEN DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE END IF 300 CONTINUE END IF END IF END IF * RETURN * * End of DTRMM . * END arpack-akloeckner-07/BLAS/ccopy.f0000644000175000017500000000137106034032725016503 0ustar andreasandreas subroutine ccopy(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 arpack-akloeckner-07/BLAS/zcopy.f0000644000175000017500000000140006034032725016523 0ustar andreasandreas subroutine zcopy(n,zx,incx,zy,incy) c c copies a vector, x, to a vector, y. c jack dongarra, linpack, 4/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*),zy(*) integer i,incx,incy,ix,iy,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n zy(iy) = zx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n zy(i) = zx(i) 30 continue return end arpack-akloeckner-07/BLAS/cgemm.f0000644000175000017500000003160006034032725016454 0ustar andreasandreas SUBROUTINE CGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC COMPLEX ALPHA, BETA * .. 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. * * Parameters * ========== * * 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. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = '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 TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * 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 .. LOGICAL CONJA, CONJB, NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB 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 .. * * 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( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) CONJA = LSAME( TRANSA, 'C' ) CONJB = LSAME( TRANSB, '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( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.CONJB ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( '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 arpack-akloeckner-07/BLAS/cgemv.f0000644000175000017500000001775206034032725016501 0ustar andreasandreas SUBROUTINE CGEMV ( 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 * .. 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, '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 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, 'T' ) * * 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 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 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE DO 100, I = 1, M TEMP = TEMP + CONJG( A( 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 IF( NOCONJ )THEN DO 120, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE ELSE DO 130, I = 1, M TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) 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 arpack-akloeckner-07/BLAS/zgemm.f0000644000175000017500000003164306034032725016512 0ustar andreasandreas SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * 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. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = conjg( B' ). * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. Local Scalars .. LOGICAL CONJA, CONJB, NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB COMPLEX*16 TEMP * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Executable Statements .. * * 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( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) CONJA = LSAME( TRANSA, 'C' ) CONJB = LSAME( TRANSB, '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( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.CONJB ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE IF( CONJA )THEN * * Form C := alpha*conjg( A' )*B + beta*C. * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 150, J = 1, N DO 140, I = 1, M TEMP = ZERO DO 130, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 130 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 140 CONTINUE 150 CONTINUE END IF ELSE IF( NOTA )THEN IF( CONJB )THEN * * Form C := alpha*A*conjg( B' ) + beta*C. * DO 200, J = 1, N IF( BETA.EQ.ZERO )THEN DO 160, I = 1, M C( I, J ) = ZERO 160 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 170, I = 1, M C( I, J ) = BETA*C( I, J ) 170 CONTINUE END IF DO 190, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( B( J, L ) ) DO 180, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 180 CONTINUE END IF 190 CONTINUE 200 CONTINUE ELSE * * Form C := alpha*A*B' + beta*C * DO 250, J = 1, N IF( BETA.EQ.ZERO )THEN DO 210, I = 1, M C( I, J ) = ZERO 210 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 220, I = 1, M C( I, J ) = BETA*C( I, J ) 220 CONTINUE END IF DO 240, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 230, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 230 CONTINUE END IF 240 CONTINUE 250 CONTINUE END IF ELSE IF( CONJA )THEN IF( CONJB )THEN * * Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. * DO 280, J = 1, N DO 270, I = 1, M TEMP = ZERO DO 260, L = 1, K TEMP = TEMP + $ DCONJG( A( L, I ) )*DCONJG( B( J, L ) ) 260 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 270 CONTINUE 280 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B' + beta*C * DO 310, J = 1, N DO 300, I = 1, M TEMP = ZERO DO 290, L = 1, K TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L ) 290 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 300 CONTINUE 310 CONTINUE END IF ELSE IF( CONJB )THEN * * Form C := alpha*A'*conjg( B' ) + beta*C * DO 340, J = 1, N DO 330, I = 1, M TEMP = ZERO DO 320, L = 1, K TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) ) 320 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 330 CONTINUE 340 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 370, J = 1, N DO 360, I = 1, M TEMP = ZERO DO 350, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 350 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 360 CONTINUE 370 CONTINUE END IF END IF * RETURN * * End of ZGEMM . * END arpack-akloeckner-07/BLAS/zgemv.f0000644000175000017500000001775506053270564016541 0ustar andreasandreas SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. COMPLEX*16 ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * ZGEMV 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*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * 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*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 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*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, KX, KY, LENX, LENY LOGICAL NOCONJ * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, '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 IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGEMV ', 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, 'T' ) * * 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 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 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE DO 100, I = 1, M TEMP = TEMP + DCONJG( A( 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 IF( NOCONJ )THEN DO 120, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE ELSE DO 130, I = 1, M TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) 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 ZGEMV . * END arpack-akloeckner-07/BLAS/cgeru.f0000644000175000017500000001043206034032725016471 0ustar andreasandreas SUBROUTINE CGERU ( 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 arpack-akloeckner-07/BLAS/zgeru.f0000644000175000017500000001043206034032725016520 0ustar andreasandreas SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. COMPLEX*16 ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * ZGERU performs the rank 1 operation * * A := alpha*x*y' + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGERU ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of ZGERU . * END arpack-akloeckner-07/BLAS/cscal.f0000644000175000017500000000116506034032726016455 0ustar andreasandreas subroutine cscal(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 arpack-akloeckner-07/BLAS/zscal.f0000644000175000017500000000116706034032726016506 0ustar andreasandreas subroutine zscal(n,za,zx,incx) c c scales a vector by a constant. c jack dongarra, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double complex za,zx(*) integer i,incx,ix,n c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 do 10 i = 1,n zx(ix) = za*zx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 do 30 i = 1,n zx(i) = za*zx(i) 30 continue return end arpack-akloeckner-07/BLAS/cswap.f0000644000175000017500000000151306034032726016502 0ustar andreasandreas subroutine cswap (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 arpack-akloeckner-07/BLAS/zswap.f0000644000175000017500000000151106034032726016527 0ustar andreasandreas subroutine zswap (n,zx,incx,zy,incy) c c interchanges two vectors. c jack dongarra, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*),zy(*),ztemp integer i,incx,incy,ix,iy,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n ztemp = zx(ix) zx(ix) = zy(iy) zy(iy) = ztemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 20 do 30 i = 1,n ztemp = zx(i) zx(i) = zy(i) zy(i) = ztemp 30 continue return end arpack-akloeckner-07/BLAS/ctbsv.f0000644000175000017500000003143106034032726016510 0ustar andreasandreas SUBROUTINE CTBSV ( 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 * ======= * * 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. * * 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. * * 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 * .. * .. 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( '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 arpack-akloeckner-07/BLAS/ztbsv.f0000644000175000017500000003144206034032726016541 0ustar andreasandreas SUBROUTINE ZTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZTBSV solves one of the systems of equations * * A*x = b, or A'*x = b, or conjg( A' )*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular band matrix, with ( k + 1 ) * diagonals. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * 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. * * K - INTEGER. * On entry with UPLO = 'U' or 'u', K specifies the number of * super-diagonals of the matrix A. * On entry with UPLO = 'L' or 'l', K specifies the number of * sub-diagonals of the matrix A. * K must satisfy 0 .le. K. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) * by n part of the array A must contain the upper triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row * ( k + 1 ) of the array, the first super-diagonal starting at * position 2 in row k, and so on. The top left k by k triangle * of the array A is not referenced. * The following program segment will transfer an upper * triangular band matrix from conventional full matrix storage * to band storage: * * DO 20, J = 1, N * M = K + 1 - J * DO 10, I = MAX( 1, J - K ), J * A( M + I, J ) = matrix( I, J ) * 10 CONTINUE * 20 CONTINUE * * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) * by n part of the array A must contain the lower triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row 1 of * the array, the first sub-diagonal starting at position 1 in * row 2, and so on. The bottom right k by k triangle of the * array A is not referenced. * The following program segment will transfer a lower * triangular band matrix from conventional full matrix storage * to band storage: * * DO 20, J = 1, N * M = 1 - J * DO 10, I = J, MIN( N, J + K ) * A( M + I, J ) = matrix( I, J ) * 10 CONTINUE * 20 CONTINUE * * Note that when DIAG = 'U' or 'u' the elements of the array A * corresponding to the diagonal elements of the matrix are not * referenced, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * ( k + 1 ). * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOCONJ, NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( K.LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.( K + 1 ) )THEN INFO = 7 ELSE IF( INCX.EQ.0 )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTBSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed by sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN L = KPLUS1 - J IF( NOUNIT ) $ X( J ) = X( J )/A( KPLUS1, J ) TEMP = X( J ) DO 10, I = J - 1, MAX( 1, J - K ), -1 X( I ) = X( I ) - TEMP*A( L + I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 40, J = N, 1, -1 KX = KX - INCX IF( X( JX ).NE.ZERO )THEN IX = KX L = KPLUS1 - J IF( NOUNIT ) $ X( JX ) = X( JX )/A( KPLUS1, J ) TEMP = X( JX ) DO 30, I = J - 1, MAX( 1, J - K ), -1 X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX - INCX 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN L = 1 - J IF( NOUNIT ) $ X( J ) = X( J )/A( 1, J ) TEMP = X( J ) DO 50, I = J + 1, MIN( N, J + K ) X( I ) = X( I ) - TEMP*A( L + I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N KX = KX + INCX IF( X( JX ).NE.ZERO )THEN IX = KX L = 1 - J IF( NOUNIT ) $ X( JX ) = X( JX )/A( 1, J ) TEMP = X( JX ) DO 70, I = J + 1, MIN( N, J + K ) X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x or x := inv( conjg( A') )*x. * IF( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = X( J ) L = KPLUS1 - J IF( NOCONJ )THEN DO 90, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( KPLUS1, J ) ELSE DO 100, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - DCONJG( A( L + I, J ) )*X( I ) 100 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( KPLUS1, J ) ) END IF X( J ) = TEMP 110 CONTINUE ELSE JX = KX DO 140, J = 1, N TEMP = X( JX ) IX = KX L = KPLUS1 - J IF( NOCONJ )THEN DO 120, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX + INCX 120 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( KPLUS1, J ) ELSE DO 130, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - DCONJG( A( L + I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( KPLUS1, J ) ) END IF X( JX ) = TEMP JX = JX + INCX IF( J.GT.K ) $ KX = KX + INCX 140 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 170, J = N, 1, -1 TEMP = X( J ) L = 1 - J IF( NOCONJ )THEN DO 150, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( I ) 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( 1, J ) ELSE DO 160, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - DCONJG( A( L + I, J ) )*X( I ) 160 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( 1, J ) ) END IF X( J ) = TEMP 170 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 200, J = N, 1, -1 TEMP = X( JX ) IX = KX L = 1 - J IF( NOCONJ )THEN DO 180, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX - INCX 180 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( 1, J ) ELSE DO 190, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - DCONJG( A( L + I, J ) )*X( IX ) IX = IX - INCX 190 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( 1, J ) ) END IF X( JX ) = TEMP JX = JX - INCX IF( ( N - J ).GE.K ) $ KX = KX - INCX 200 CONTINUE END IF END IF END IF * RETURN * * End of ZTBSV . * END arpack-akloeckner-07/BLAS/ctrsm.f0000644000175000017500000003302606034032726016521 0ustar andreasandreas SUBROUTINE CTRSM ( 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, '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, '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' ) )THEN * * Form B := alpha*inv( A )*B. * IF( UPPER )THEN DO 60, J = 1, N IF( ALPHA.NE.ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE END IF DO 50, K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE END IF 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N IF( ALPHA.NE.ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE END IF DO 90 K = 1, M IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE END IF 90 CONTINUE 100 CONTINUE END IF ELSE * * Form B := alpha*inv( A' )*B * 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' ) )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 DO 200, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 200 CONTINUE END IF 210 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) 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 DO 250, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 250 CONTINUE END IF 260 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) 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 arpack-akloeckner-07/BLAS/ztrsm.f0000644000175000017500000003303706034032726016552 0ustar andreasandreas SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB COMPLEX*16 ALPHA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZTRSM solves one of the matrix equations * * op( A )*X = alpha*B, or X*op( A ) = alpha*B, * * where alpha is a scalar, X and B are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * The matrix X is overwritten on B. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*B. * * SIDE = 'R' or 'r' X*op( A ) = alpha*B. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the right-hand side matrix B, and on exit is * overwritten by the solution matrix X. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. Local Scalars .. LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA COMPLEX*16 TEMP * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOCONJ = LSAME( TRANSA, '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, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTRSM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*inv( A )*B. * IF( UPPER )THEN DO 60, J = 1, N IF( ALPHA.NE.ONE )THEN DO 30, I = 1, M B( I, J ) = ALPHA*B( I, J ) 30 CONTINUE END IF DO 50, K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 40, I = 1, K - 1 B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 40 CONTINUE END IF 50 CONTINUE 60 CONTINUE ELSE DO 100, J = 1, N IF( ALPHA.NE.ONE )THEN DO 70, I = 1, M B( I, J ) = ALPHA*B( I, J ) 70 CONTINUE END IF DO 90 K = 1, M IF( B( K, J ).NE.ZERO )THEN IF( NOUNIT ) $ B( K, J ) = B( K, J )/A( K, K ) DO 80, I = K + 1, M B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) 80 CONTINUE END IF 90 CONTINUE 100 CONTINUE END IF ELSE * * Form B := alpha*inv( A' )*B * or B := alpha*inv( conjg( A' ) )*B. * IF( UPPER )THEN DO 140, J = 1, N DO 130, I = 1, M TEMP = ALPHA*B( I, J ) IF( NOCONJ )THEN DO 110, K = 1, I - 1 TEMP = TEMP - A( K, I )*B( K, J ) 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) ELSE DO 120, K = 1, I - 1 TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) 120 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( I, I ) ) END IF B( I, J ) = TEMP 130 CONTINUE 140 CONTINUE ELSE DO 180, J = 1, N DO 170, I = M, 1, -1 TEMP = ALPHA*B( I, J ) IF( NOCONJ )THEN DO 150, K = I + 1, M TEMP = TEMP - A( K, I )*B( K, J ) 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( I, I ) ELSE DO 160, K = I + 1, M TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J ) 160 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( I, I ) ) END IF B( I, J ) = TEMP 170 CONTINUE 180 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )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 DO 200, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 200 CONTINUE END IF 210 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) 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 DO 250, I = 1, M B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) 250 CONTINUE END IF 260 CONTINUE IF( NOUNIT )THEN TEMP = ONE/A( J, J ) DO 270, I = 1, M B( I, J ) = TEMP*B( I, J ) 270 CONTINUE END IF 280 CONTINUE END IF ELSE * * Form B := alpha*B*inv( A' ) * or B := alpha*B*inv( conjg( A' ) ). * IF( UPPER )THEN DO 330, K = N, 1, -1 IF( NOUNIT )THEN IF( NOCONJ )THEN TEMP = ONE/A( K, K ) ELSE TEMP = ONE/DCONJG( A( K, K ) ) END IF DO 290, I = 1, M B( I, K ) = TEMP*B( I, K ) 290 CONTINUE END IF DO 310, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN IF( NOCONJ )THEN TEMP = A( J, K ) ELSE TEMP = DCONJG( A( J, K ) ) END IF DO 300, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 300 CONTINUE END IF 310 CONTINUE IF( ALPHA.NE.ONE )THEN DO 320, I = 1, M B( I, K ) = ALPHA*B( I, K ) 320 CONTINUE END IF 330 CONTINUE ELSE DO 380, K = 1, N IF( NOUNIT )THEN IF( NOCONJ )THEN TEMP = ONE/A( K, K ) ELSE TEMP = ONE/DCONJG( A( K, K ) ) END IF DO 340, I = 1, M B( I, K ) = TEMP*B( I, K ) 340 CONTINUE END IF DO 360, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN IF( NOCONJ )THEN TEMP = A( J, K ) ELSE TEMP = DCONJG( A( J, K ) ) END IF DO 350, I = 1, M B( I, J ) = B( I, J ) - TEMP*B( I, K ) 350 CONTINUE END IF 360 CONTINUE IF( ALPHA.NE.ONE )THEN DO 370, I = 1, M B( I, K ) = ALPHA*B( I, K ) 370 CONTINUE END IF 380 CONTINUE END IF END IF END IF * RETURN * * End of ZTRSM . * END arpack-akloeckner-07/BLAS/dgbmv.f0000644000175000017500000002211706034032727016470 0ustar andreasandreas SUBROUTINE DGBMV ( 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 arpack-akloeckner-07/BLAS/sgbmv.f0000644000175000017500000002211706034032727016507 0ustar andreasandreas SUBROUTINE SGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, KL, KU, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * SGBMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n band matrix, with kl sub-diagonals and ku super-diagonals. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * KL - INTEGER. * On entry, KL specifies the number of sub-diagonals of the * matrix A. KL must satisfy 0 .le. KL. * Unchanged on exit. * * KU - INTEGER. * On entry, KU specifies the number of super-diagonals of the * matrix A. KU must satisfy 0 .le. KU. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry, the leading ( kl + ku + 1 ) by n part of the * array A must contain the matrix of coefficients, supplied * column by column, with the leading diagonal of the matrix in * row ( ku + 1 ) of the array, the first super-diagonal * starting at position 2 in row ku, the first sub-diagonal * starting at position 1 in row ( ku + 2 ), and so on. * Elements in the array A that do not correspond to elements * in the band matrix (such as the top left ku by ku triangle) * are not referenced. * The following program segment will transfer a band matrix * from conventional full matrix storage to band storage: * * DO 20, J = 1, N * K = KU + 1 - J * DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) * A( K + I, J ) = matrix( I, J ) * 10 CONTINUE * 20 CONTINUE * * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * ( kl + ku + 1 ). * Unchanged on exit. * * X - REAL array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - REAL array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry, the incremented array Y must contain the * vector y. On exit, Y is overwritten by the updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, $ LENX, LENY * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( KL.LT.0 )THEN INFO = 4 ELSE IF( KU.LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN INFO = 8 ELSE IF( INCX.EQ.0 )THEN INFO = 10 ELSE IF( INCY.EQ.0 )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGBMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * Set LENX and LENY, the lengths of the vectors x and y, and set * up the start points in X and Y. * IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the band part of A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN KUP1 = KU + 1 IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) K = KUP1 - J DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) Y( I ) = Y( I ) + TEMP*A( K + I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY K = KUP1 - J DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX IF( J.GT.KU ) $ KY = KY + INCY 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = ZERO K = KUP1 - J DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX K = KUP1 - J DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY IF( J.GT.KU ) $ KX = KX + INCX 120 CONTINUE END IF END IF * RETURN * * End of SGBMV . * END arpack-akloeckner-07/BLAS/dtbsv.f0000644000175000017500000002632406034032727016517 0ustar andreasandreas SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DTBSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular band matrix, with ( k + 1 ) * diagonals. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with UPLO = 'U' or 'u', K specifies the number of * super-diagonals of the matrix A. * On entry with UPLO = 'L' or 'l', K specifies the number of * sub-diagonals of the matrix A. * K must satisfy 0 .le. K. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) * by n part of the array A must contain the upper triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row * ( k + 1 ) of the array, the first super-diagonal starting at * position 2 in row k, and so on. The top left k by k triangle * of the array A is not referenced. * The following program segment will transfer an upper * triangular band matrix from conventional full matrix storage * to band storage: * * DO 20, J = 1, N * M = K + 1 - J * DO 10, I = MAX( 1, J - K ), J * A( M + I, J ) = matrix( I, J ) * 10 CONTINUE * 20 CONTINUE * * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) * by n part of the array A must contain the lower triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row 1 of * the array, the first sub-diagonal starting at position 1 in * row 2, and so on. The bottom right k by k triangle of the * array A is not referenced. * The following program segment will transfer a lower * triangular band matrix from conventional full matrix storage * to band storage: * * DO 20, J = 1, N * M = 1 - J * DO 10, I = J, MIN( N, J + K ) * A( M + I, J ) = matrix( I, J ) * 10 CONTINUE * 20 CONTINUE * * Note that when DIAG = 'U' or 'u' the elements of the array A * corresponding to the diagonal elements of the matrix are not * referenced, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * ( k + 1 ). * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. 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( 'DTBSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed by sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN L = KPLUS1 - J IF( NOUNIT ) $ X( J ) = X( J )/A( KPLUS1, J ) TEMP = X( J ) DO 10, I = J - 1, MAX( 1, J - K ), -1 X( I ) = X( I ) - TEMP*A( L + I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 40, J = N, 1, -1 KX = KX - INCX IF( X( JX ).NE.ZERO )THEN IX = KX L = KPLUS1 - J IF( NOUNIT ) $ X( JX ) = X( JX )/A( KPLUS1, J ) TEMP = X( JX ) DO 30, I = J - 1, MAX( 1, J - K ), -1 X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX - INCX 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN L = 1 - J IF( NOUNIT ) $ X( J ) = X( J )/A( 1, J ) TEMP = X( J ) DO 50, I = J + 1, MIN( N, J + K ) X( I ) = X( I ) - TEMP*A( L + I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N KX = KX + INCX IF( X( JX ).NE.ZERO )THEN IX = KX L = 1 - J IF( NOUNIT ) $ X( JX ) = X( JX )/A( 1, J ) TEMP = X( JX ) DO 70, I = J + 1, MIN( N, J + K ) X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A')*x. * IF( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = X( J ) L = KPLUS1 - J DO 90, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( KPLUS1, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX L = KPLUS1 - J DO 110, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX + INCX 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( KPLUS1, J ) X( JX ) = TEMP JX = JX + INCX IF( J.GT.K ) $ KX = KX + INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) L = 1 - J DO 130, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( I ) 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( 1, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX L = 1 - J DO 150, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX - INCX 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( 1, J ) X( JX ) = TEMP JX = JX - INCX IF( ( N - J ).GE.K ) $ KX = KX - INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of DTBSV . * END arpack-akloeckner-07/BLAS/stbsv.f0000644000175000017500000002632406034032727016536 0ustar andreasandreas SUBROUTINE STBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, K, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. REAL A( LDA, * ), X( * ) * .. * * Purpose * ======= * * STBSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular band matrix, with ( k + 1 ) * diagonals. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with UPLO = 'U' or 'u', K specifies the number of * super-diagonals of the matrix A. * On entry with UPLO = 'L' or 'l', K specifies the number of * sub-diagonals of the matrix A. * K must satisfy 0 .le. K. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) * by n part of the array A must contain the upper triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row * ( k + 1 ) of the array, the first super-diagonal starting at * position 2 in row k, and so on. The top left k by k triangle * of the array A is not referenced. * The following program segment will transfer an upper * triangular band matrix from conventional full matrix storage * to band storage: * * DO 20, J = 1, N * M = K + 1 - J * DO 10, I = MAX( 1, J - K ), J * A( M + I, J ) = matrix( I, J ) * 10 CONTINUE * 20 CONTINUE * * Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) * by n part of the array A must contain the lower triangular * band part of the matrix of coefficients, supplied column by * column, with the leading diagonal of the matrix in row 1 of * the array, the first sub-diagonal starting at position 1 in * row 2, and so on. The bottom right k by k triangle of the * array A is not referenced. * The following program segment will transfer a lower * triangular band matrix from conventional full matrix storage * to band storage: * * DO 20, J = 1, N * M = 1 - J * DO 10, I = J, MIN( N, J + K ) * A( M + I, J ) = matrix( I, J ) * 10 CONTINUE * 20 CONTINUE * * Note that when DIAG = 'U' or 'u' the elements of the array A * corresponding to the diagonal elements of the matrix are not * referenced, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * ( k + 1 ). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. 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( 'STBSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed by sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN L = KPLUS1 - J IF( NOUNIT ) $ X( J ) = X( J )/A( KPLUS1, J ) TEMP = X( J ) DO 10, I = J - 1, MAX( 1, J - K ), -1 X( I ) = X( I ) - TEMP*A( L + I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 40, J = N, 1, -1 KX = KX - INCX IF( X( JX ).NE.ZERO )THEN IX = KX L = KPLUS1 - J IF( NOUNIT ) $ X( JX ) = X( JX )/A( KPLUS1, J ) TEMP = X( JX ) DO 30, I = J - 1, MAX( 1, J - K ), -1 X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX - INCX 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN L = 1 - J IF( NOUNIT ) $ X( J ) = X( J )/A( 1, J ) TEMP = X( J ) DO 50, I = J + 1, MIN( N, J + K ) X( I ) = X( I ) - TEMP*A( L + I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N KX = KX + INCX IF( X( JX ).NE.ZERO )THEN IX = KX L = 1 - J IF( NOUNIT ) $ X( JX ) = X( JX )/A( 1, J ) TEMP = X( JX ) DO 70, I = J + 1, MIN( N, J + K ) X( IX ) = X( IX ) - TEMP*A( L + I, J ) IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A')*x. * IF( LSAME( UPLO, 'U' ) )THEN KPLUS1 = K + 1 IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = X( J ) L = KPLUS1 - J DO 90, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( KPLUS1, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX L = KPLUS1 - J DO 110, I = MAX( 1, J - K ), J - 1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX + INCX 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( KPLUS1, J ) X( JX ) = TEMP JX = JX + INCX IF( J.GT.K ) $ KX = KX + INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) L = 1 - J DO 130, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( I ) 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( 1, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX L = 1 - J DO 150, I = MIN( N, J + K ), J + 1, -1 TEMP = TEMP - A( L + I, J )*X( IX ) IX = IX - INCX 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( 1, J ) X( JX ) = TEMP JX = JX - INCX IF( ( N - J ).GE.K ) $ KX = KX - INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of STBSV . * END arpack-akloeckner-07/BLAS/icamax.f0000644000175000017500000000200506034032727016625 0ustar andreasandreas integer function icamax(n,cx,incx) c c finds the index of element having max. absolute value. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c complex cx(*) real smax integer i,incx,ix,n complex zdum real cabs1 cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) c icamax = 0 if( n.lt.1 .or. incx.le.0 ) return icamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 smax = cabs1(cx(1)) ix = ix + incx do 10 i = 2,n if(cabs1(cx(ix)).le.smax) go to 5 icamax = i smax = cabs1(cx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 smax = cabs1(cx(1)) do 30 i = 2,n if(cabs1(cx(i)).le.smax) go to 30 icamax = i smax = cabs1(cx(i)) 30 continue return end arpack-akloeckner-07/BLAS/izamax.f0000644000175000017500000000223606034032727016662 0ustar andreasandreas integer function izamax(n,zx,incx) c c finds the index of element having max. absolute value. c jack dongarra, 1/15/85. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*) double precision smax integer i,incx,ix,n double precision dcabs1 c izamax = 0 if( n.lt.1 .or. incx.le.0 )return izamax = 1 if(n.eq.1)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 smax = dcabs1(zx(1)) ix = ix + incx do 10 i = 2,n if(dcabs1(zx(ix)).le.smax) go to 5 izamax = i smax = dcabs1(zx(ix)) 5 ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 smax = dcabs1(zx(1)) do 30 i = 2,n if(dcabs1(zx(i)).le.smax) go to 30 izamax = i smax = dcabs1(zx(i)) 30 continue return end double precision function dcabs1(z) double complex z,zz double precision t(2) equivalence (zz,t(1)) zz = z dcabs1 = dabs(t(1)) + dabs(t(2)) return end arpack-akloeckner-07/BLAS/caxpy.f0000644000175000017500000000152306052762721016517 0ustar andreasandreas subroutine caxpy(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 arpack-akloeckner-07/BLAS/cdotc.f0000644000175000017500000000165506052762724016500 0ustar andreasandreas complex function cdotc(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) cdotc = (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 cdotc = 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 cdotc = ctemp return end arpack-akloeckner-07/BLAS/cdotu.f0000644000175000017500000000157206052762724016520 0ustar andreasandreas complex function cdotu(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) cdotu = (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 cdotu = 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 cdotu = ctemp return end arpack-akloeckner-07/BLAS/cgbmv.f0000644000175000017500000002351006052762724016474 0ustar andreasandreas SUBROUTINE CGBMV ( 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 * ======= * * CGBMV 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 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX 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 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, 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, K, KUP1, KX, KY, $ LENX, LENY LOGICAL NOCONJ * .. 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, '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( 'CGBMV ', 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, 'T' ) * * 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 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 * RETURN * * End of CGBMV . * END arpack-akloeckner-07/BLAS/cgerc.f0000644000175000017500000001047406052762726016470 0ustar andreasandreas SUBROUTINE CGERC ( 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 arpack-akloeckner-07/BLAS/Makefile0000644000175000017500000000644306221771250016665 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: Makefile # # Purpose: Sources Makefile # # Creation date: February 22, 1996 # # Modified: September 6, 1996 # # Send bug reports, comments or suggestions to arpack.caam.rice.edu # ############################################################################ #\SCCS Information: @(#) # FILE: Makefile SID: 2.3 DATE OF SID: 9/24/96 RELEASE: 2 include ../ARmake.inc ############################################################################ # To create or add to the library, enter make followed by one or # more of the precisions desired. Targets sdrv, ddrv, cdrv, # zdrv are used to add to the ARPACK library those BLAS routines needed by # driver programs in the EXAMPLES directory. # # Some examples: # make single # make single complex # make single sdrv # make single double complex complex16 # Alternatively, the command # make # without any arguments creates a library of all four precisions. # The library also contains all extra BLAS routines used by driver # programs in the EXAMPLES directory. # # The name of the library is defined by $(ARPACKLIB) in # ../ARmake.inc and is created at the next higher directory level. # # SOBJ = isamax.o sasum.o saxpy.o scopy.o sdot.o snrm2.o srot.o srotg.o\ sscal.o sswap.o sgemv.o sger.o ssymv.o ssyr2.o strmm.o sgbmv.o DOBJ = idamax.o dasum.o daxpy.o dcopy.o ddot.o dnrm2.o drot.o drotg.o\ dscal.o dswap.o dgemv.o dger.o dsymv.o dsyr2.o dtrmm.o dgbmv.o COBJ = icamax.o caxpy.o ccopy.o cdotc.o cdotu.o cgbmv.o cgemv.o cgerc.o\ cgeru.o cscal.o csscal.o cswap.o ctrmm.o ctrsv.o scasum.o scnrm2.o\ isamax.o sscal.o ZOBJ = izamax.o zaxpy.o zcopy.o zdotc.o zdotu.o zgbmv.o zgemv.o zgerc.o\ zgeru.o zscal.o zdscal.o zswap.o ztrmm.o ztrsv.o dzasum.o dznrm2.o\ idamax.o dscal.o # The following BLAS routine are not required by ARPACK source code. # They are called by the driver programs in the EXAMPLES directory. # SDRVOBJ = sgemm.o strsm.o stbsv.o DDRVOBJ = dgemm.o dtrsm.o dtbsv.o CDRVOBJ = ccopy.o cgemv.o cgeru.o cgemm.o cscal.o cswap.o ctrsm.o ctbsv.o\ icamax.o ZDRVOBJ = zcopy.o zgemv.o zgeru.o zgemm.o zscal.o zswap.o ztrsm.o ztbsv.o\ izamax.o .SUFFIXES: .o .F .f .f.o: $(FC) $(FFLAGS) -c $< all: single double complex complex16 sdrv ddrv cdrv zdrv single: $(SOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ) $(RANLIB) $(ARPACKLIB) double: $(DOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ) $(RANLIB) $(ARPACKLIB) complex: $(COBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(COBJ) $(RANLIB) $(ARPACKLIB) complex16: $(ZOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(ZOBJ) $(RANLIB) $(ARPACKLIB) # # Add routines needed by driver programs (in the EXAMPLES # directory) to $(ARPACKLIB). # sdrv: $(SDRVOBJ) $(CDRVOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(SDRVOBJ) $(CDRVOBJ) $(RANLIB) $(ARPACKLIB) ddrv: $(DDRVOBJ) $(ZDRVOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(DDRVOBJ) $(ZDRVOBJ) $(RANLIB) $(ARPACKLIB) cdrv: $(CDRVOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(CDRVOBJ) $(RANLIB) $(ARPACKLIB) zdrv: $(ZDRVOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(ZDRVOBJ) $(RANLIB) $(ARPACKLIB) # # clean - remove all object files # clean: rm -f *.o a.out core arpack-akloeckner-07/BLAS/csscal.f0000644000175000017500000000130706052762727016651 0ustar andreasandreas subroutine csscal(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 arpack-akloeckner-07/BLAS/ctrmm.f0000644000175000017500000003142706052762730016523 0ustar andreasandreas SUBROUTINE CTRMM ( 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.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, '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, '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' ) )THEN * * Form B := alpha*A*B. * IF( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) B( K, J ) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP IF( NOUNIT ) $ B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE * * Form B := alpha*B*A' or B := alpha*B*conjg( A' ). * 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' ) )THEN * * Form B := alpha*B*A. * IF( UPPER )THEN DO 200, J = N, 1, -1 TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) 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 TEMP = ALPHA*A( K, J ) 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( NOUNIT ) $ TEMP = TEMP*A( J, J ) 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 TEMP = ALPHA*A( K, J ) 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 arpack-akloeckner-07/BLAS/ctrsv.f0000644000175000017500000002445606052762731016547 0ustar andreasandreas SUBROUTINE CTRSV ( 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, '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, '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 := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x 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 arpack-akloeckner-07/BLAS/dzasum.f0000644000175000017500000000142706052762742016704 0ustar andreasandreas double precision function dzasum(n,zx,incx) c c takes the sum of the absolute values. c jack dongarra, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*) double precision stemp,dcabs1 integer i,incx,ix,n c dzasum = 0.0d0 stemp = 0.0d0 if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 do 10 i = 1,n stemp = stemp + dcabs1(zx(ix)) ix = ix + incx 10 continue dzasum = stemp return c c code for increment equal to 1 c 20 do 30 i = 1,n stemp = stemp + dcabs1(zx(i)) 30 continue dzasum = stemp return end arpack-akloeckner-07/BLAS/dznrm2.f0000644000175000017500000000366306052762742016621 0ustar andreasandreas DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, N * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * DZNRM2 returns the euclidean norm of a vector via the function * name, so that * * DZNRM2 := sqrt( conjg( x' )*x ) * * * * -- This version written on 25-October-1982. * Modified on 14-October-1993 to inline the call to ZLASSQ. * Sven Hammarling, Nag Ltd. * * * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. Local Scalars .. INTEGER IX DOUBLE PRECISION NORM, SCALE, SSQ, TEMP * .. Intrinsic Functions .. INTRINSIC ABS, DIMAG, DBLE, SQRT * .. * .. Executable Statements .. IF( N.LT.1 .OR. INCX.LT.1 )THEN NORM = ZERO ELSE SCALE = ZERO SSQ = ONE * The following loop is equivalent to this call to the LAPACK * auxiliary routine: * CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) * DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX IF( DBLE( X( IX ) ).NE.ZERO )THEN TEMP = ABS( DBLE( X( IX ) ) ) IF( SCALE.LT.TEMP )THEN SSQ = ONE + SSQ*( SCALE/TEMP )**2 SCALE = TEMP ELSE SSQ = SSQ + ( TEMP/SCALE )**2 END IF END IF IF( DIMAG( X( IX ) ).NE.ZERO )THEN TEMP = ABS( DIMAG( X( IX ) ) ) IF( SCALE.LT.TEMP )THEN SSQ = ONE + SSQ*( SCALE/TEMP )**2 SCALE = TEMP ELSE SSQ = SSQ + ( TEMP/SCALE )**2 END IF END IF 10 CONTINUE NORM = SCALE * SQRT( SSQ ) END IF * DZNRM2 = NORM RETURN * * End of DZNRM2. * END arpack-akloeckner-07/BLAS/scasum.f0000644000175000017500000000154406052762750016673 0ustar andreasandreas real function scasum(n,cx,incx) c c takes the sum of the absolute values of a complex vector and c returns a single precision result. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c complex cx(*) real stemp integer i,incx,n,nincx c scasum = 0.0e0 stemp = 0.0e0 if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i))) 10 continue scasum = stemp return c c code for increment equal to 1 c 20 do 30 i = 1,n stemp = stemp + abs(real(cx(i))) + abs(aimag(cx(i))) 30 continue scasum = stemp return end arpack-akloeckner-07/BLAS/scnrm2.f0000644000175000017500000000366306052762750016610 0ustar andreasandreas REAL FUNCTION SCNRM2( N, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, N * .. Array Arguments .. COMPLEX X( * ) * .. * * SCNRM2 returns the euclidean norm of a vector via the function * name, so that * * SCNRM2 := sqrt( conjg( x' )*x ) * * * * -- This version written on 25-October-1982. * Modified on 14-October-1993 to inline the call to CLASSQ. * Sven Hammarling, Nag Ltd. * * * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. Local Scalars .. INTEGER IX REAL NORM, SCALE, SSQ, TEMP * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, REAL, SQRT * .. * .. Executable Statements .. IF( N.LT.1 .OR. INCX.LT.1 )THEN NORM = ZERO ELSE SCALE = ZERO SSQ = ONE * The following loop is equivalent to this call to the LAPACK * auxiliary routine: * CALL CLASSQ( N, X, INCX, SCALE, SSQ ) * DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX IF( REAL( X( IX ) ).NE.ZERO )THEN TEMP = ABS( REAL( X( IX ) ) ) IF( SCALE.LT.TEMP )THEN SSQ = ONE + SSQ*( SCALE/TEMP )**2 SCALE = TEMP ELSE SSQ = SSQ + ( TEMP/SCALE )**2 END IF END IF IF( AIMAG( X( IX ) ).NE.ZERO )THEN TEMP = ABS( AIMAG( X( IX ) ) ) IF( SCALE.LT.TEMP )THEN SSQ = ONE + SSQ*( SCALE/TEMP )**2 SCALE = TEMP ELSE SSQ = SSQ + ( TEMP/SCALE )**2 END IF END IF 10 CONTINUE NORM = SCALE * SQRT( SSQ ) END IF * SCNRM2 = NORM RETURN * * End of SCNRM2. * END arpack-akloeckner-07/BLAS/zaxpy.f0000644000175000017500000000153306052762761016553 0ustar andreasandreas subroutine zaxpy(n,za,zx,incx,zy,incy) c c constant times a vector plus a vector. c jack dongarra, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*),zy(*),za integer i,incx,incy,ix,iy,n double precision dcabs1 if(n.le.0)return if (dcabs1(za) .eq. 0.0d0) return if (incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n zy(iy) = zy(iy) + za*zx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n zy(i) = zy(i) + za*zx(i) 30 continue return end arpack-akloeckner-07/BLAS/zdotc.f0000644000175000017500000000162206052762761016522 0ustar andreasandreas double complex function zdotc(n,zx,incx,zy,incy) c c forms the dot product of a vector. c jack dongarra, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*),zy(*),ztemp integer i,incx,incy,ix,iy,n ztemp = (0.0d0,0.0d0) zdotc = (0.0d0,0.0d0) if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n ztemp = ztemp + dconjg(zx(ix))*zy(iy) ix = ix + incx iy = iy + incy 10 continue zdotc = ztemp return c c code for both increments equal to 1 c 20 do 30 i = 1,n ztemp = ztemp + dconjg(zx(i))*zy(i) 30 continue zdotc = ztemp return end arpack-akloeckner-07/BLAS/zdotu.f0000644000175000017500000000160506052762761016545 0ustar andreasandreas double complex function zdotu(n,zx,incx,zy,incy) c c forms the dot product of two vectors. c jack dongarra, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*),zy(*),ztemp integer i,incx,incy,ix,iy,n ztemp = (0.0d0,0.0d0) zdotu = (0.0d0,0.0d0) if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n ztemp = ztemp + zx(ix)*zy(iy) ix = ix + incx iy = iy + incy 10 continue zdotu = ztemp return c c code for both increments equal to 1 c 20 do 30 i = 1,n ztemp = ztemp + zx(i)*zy(i) 30 continue zdotu = ztemp return end arpack-akloeckner-07/BLAS/zdscal.f0000644000175000017500000000125306052762761016657 0ustar andreasandreas subroutine zdscal(n,da,zx,incx) c c scales a vector by a constant. c jack dongarra, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*) double precision da integer i,incx,ix,n c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 do 10 i = 1,n zx(ix) = dcmplx(da,0.0d0)*zx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 do 30 i = 1,n zx(i) = dcmplx(da,0.0d0)*zx(i) 30 continue return end arpack-akloeckner-07/BLAS/zgbmv.f0000644000175000017500000002351306052762762016530 0ustar andreasandreas SUBROUTINE ZGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. COMPLEX*16 ALPHA, BETA INTEGER INCX, INCY, KL, KU, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * ZGBMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or * * y := alpha*conjg( A' )*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n band matrix, with kl sub-diagonals and ku super-diagonals. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * KL - INTEGER. * On entry, KL specifies the number of sub-diagonals of the * matrix A. KL must satisfy 0 .le. KL. * Unchanged on exit. * * KU - INTEGER. * On entry, KU specifies the number of super-diagonals of the * matrix A. KU must satisfy 0 .le. KU. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry, the leading ( kl + ku + 1 ) by n part of the * array A must contain the matrix of coefficients, supplied * column by column, with the leading diagonal of the matrix in * row ( ku + 1 ) of the array, the first super-diagonal * starting at position 2 in row ku, the first sub-diagonal * starting at position 1 in row ( ku + 2 ), and so on. * Elements in the array A that do not correspond to elements * in the band matrix (such as the top left ku by ku triangle) * are not referenced. * The following program segment will transfer a band matrix * from conventional full matrix storage to band storage: * * DO 20, J = 1, N * K = KU + 1 - J * DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) * A( K + I, J ) = matrix( I, J ) * 10 CONTINUE * 20 CONTINUE * * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * ( kl + ku + 1 ). * Unchanged on exit. * * X - COMPLEX*16 array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - COMPLEX*16 array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry, the incremented array Y must contain the * vector y. On exit, Y is overwritten by the updated vector y. * * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, $ LENX, LENY LOGICAL NOCONJ * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, '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( '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, 'T' ) * * 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 or y := alpha*conjg( A' )*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = ZERO K = KUP1 - J IF( NOCONJ )THEN DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( I ) 90 CONTINUE ELSE DO 100, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + DCONJG( A( K + I, J ) )*X( I ) 100 CONTINUE END IF Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 110 CONTINUE ELSE DO 140, J = 1, N TEMP = ZERO IX = KX K = KUP1 - J IF( NOCONJ )THEN DO 120, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + A( K + I, J )*X( IX ) IX = IX + INCX 120 CONTINUE ELSE DO 130, I = MAX( 1, J - KU ), MIN( M, J + KL ) TEMP = TEMP + DCONJG( A( K + I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE END IF Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY IF( J.GT.KU ) $ KX = KX + INCX 140 CONTINUE END IF END IF * RETURN * * End of ZGBMV . * END arpack-akloeckner-07/BLAS/zgerc.f0000644000175000017500000001047706052762763016523 0ustar andreasandreas SUBROUTINE ZGERC ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. COMPLEX*16 ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * ZGERC performs the rank 1 operation * * A := alpha*x*conjg( y' ) + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGERC ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( Y( JY ) ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( Y( JY ) ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of ZGERC . * END arpack-akloeckner-07/BLAS/ztrmm.f0000644000175000017500000003144006052762765016555 0ustar andreasandreas SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ B, LDB ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDB COMPLEX*16 ALPHA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZTRMM performs one of the matrix-matrix operations * * B := alpha*op( A )*B, or B := alpha*B*op( A ) * * where alpha is a scalar, B is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies B from * the left or right as follows: * * SIDE = 'L' or 'l' B := alpha*op( A )*B. * * SIDE = 'R' or 'r' B := alpha*B*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of B. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of B. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and B need not be set before * entry. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B, and on exit is overwritten by the * transformed matrix. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. Local Scalars .. LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER INTEGER I, INFO, J, K, NROWA COMPLEX*16 TEMP * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE , 'L' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF NOCONJ = LSAME( TRANSA, '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, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN INFO = 4 ELSE IF( M .LT.0 )THEN INFO = 5 ELSE IF( N .LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*A*B. * IF( UPPER )THEN DO 50, J = 1, N DO 40, K = 1, M IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) DO 30, I = 1, K - 1 B( I, J ) = B( I, J ) + TEMP*A( I, K ) 30 CONTINUE IF( NOUNIT ) $ TEMP = TEMP*A( K, K ) B( K, J ) = TEMP END IF 40 CONTINUE 50 CONTINUE ELSE DO 80, J = 1, N DO 70 K = M, 1, -1 IF( B( K, J ).NE.ZERO )THEN TEMP = ALPHA*B( K, J ) B( K, J ) = TEMP IF( NOUNIT ) $ B( K, J ) = B( K, J )*A( K, K ) DO 60, I = K + 1, M B( I, J ) = B( I, J ) + TEMP*A( I, K ) 60 CONTINUE END IF 70 CONTINUE 80 CONTINUE END IF ELSE * * Form B := alpha*B*A' or B := alpha*B*conjg( A' ). * IF( UPPER )THEN DO 120, J = 1, N DO 110, I = M, 1, -1 TEMP = B( I, J ) IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 90, K = 1, I - 1 TEMP = TEMP + A( K, I )*B( K, J ) 90 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*DCONJG( A( I, I ) ) DO 100, K = 1, I - 1 TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) 100 CONTINUE END IF B( I, J ) = ALPHA*TEMP 110 CONTINUE 120 CONTINUE ELSE DO 160, J = 1, N DO 150, I = 1, M TEMP = B( I, J ) IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( I, I ) DO 130, K = I + 1, M TEMP = TEMP + A( K, I )*B( K, J ) 130 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*DCONJG( A( I, I ) ) DO 140, K = I + 1, M TEMP = TEMP + DCONJG( A( K, I ) )*B( K, J ) 140 CONTINUE END IF B( I, J ) = ALPHA*TEMP 150 CONTINUE 160 CONTINUE END IF END IF ELSE IF( LSAME( TRANSA, 'N' ) )THEN * * Form B := alpha*B*A. * IF( UPPER )THEN DO 200, J = N, 1, -1 TEMP = ALPHA IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) 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 TEMP = ALPHA*A( K, J ) 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( NOUNIT ) $ TEMP = TEMP*A( J, J ) 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 TEMP = ALPHA*A( K, J ) DO 220, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 220 CONTINUE END IF 230 CONTINUE 240 CONTINUE END IF ELSE * * Form B := alpha*B*A' or B := alpha*B*conjg( A' ). * IF( UPPER )THEN DO 280, K = 1, N DO 260, J = 1, K - 1 IF( A( J, K ).NE.ZERO )THEN IF( NOCONJ )THEN TEMP = ALPHA*A( J, K ) ELSE TEMP = ALPHA*DCONJG( A( J, K ) ) END IF DO 250, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 250 CONTINUE END IF 260 CONTINUE TEMP = ALPHA IF( NOUNIT )THEN IF( NOCONJ )THEN TEMP = TEMP*A( K, K ) ELSE TEMP = TEMP*DCONJG( A( K, K ) ) END IF END IF IF( TEMP.NE.ONE )THEN DO 270, I = 1, M B( I, K ) = TEMP*B( I, K ) 270 CONTINUE END IF 280 CONTINUE ELSE DO 320, K = N, 1, -1 DO 300, J = K + 1, N IF( A( J, K ).NE.ZERO )THEN IF( NOCONJ )THEN TEMP = ALPHA*A( J, K ) ELSE TEMP = ALPHA*DCONJG( A( J, K ) ) END IF DO 290, I = 1, M B( I, J ) = B( I, J ) + TEMP*B( I, K ) 290 CONTINUE END IF 300 CONTINUE TEMP = ALPHA IF( NOUNIT )THEN IF( NOCONJ )THEN TEMP = TEMP*A( K, K ) ELSE TEMP = TEMP*DCONJG( A( K, K ) ) END IF END IF IF( TEMP.NE.ONE )THEN DO 310, I = 1, M B( I, K ) = TEMP*B( I, K ) 310 CONTINUE END IF 320 CONTINUE END IF END IF END IF * RETURN * * End of ZTRMM . * END arpack-akloeckner-07/BLAS/ztrsv.f0000644000175000017500000002446706052762765016607 0ustar andreasandreas SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZTRSV solves one of the systems of equations * * A*x = b, or A'*x = b, or conjg( A' )*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' conjg( A' )*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOCONJ, NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTRSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOCONJ = LSAME( TRANS, '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 := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = X( J ) IF( NOCONJ )THEN DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 100, I = 1, J - 1 TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) 100 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( J ) = TEMP 110 CONTINUE ELSE JX = KX DO 140, J = 1, N IX = KX TEMP = X( JX ) IF( NOCONJ )THEN DO 120, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 130, I = 1, J - 1 TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( JX ) = TEMP JX = JX + INCX 140 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 170, J = N, 1, -1 TEMP = X( J ) IF( NOCONJ )THEN DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 160, I = N, J + 1, -1 TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) 160 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( J ) = TEMP 170 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 200, J = N, 1, -1 IX = KX TEMP = X( JX ) IF( NOCONJ )THEN DO 180, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 180 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 190, I = N, J + 1, -1 TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) IX = IX - INCX 190 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( JX ) = TEMP JX = JX - INCX 200 CONTINUE END IF END IF END IF * RETURN * * End of ZTRSV . * END arpack-akloeckner-07/LAPACK/0000755000175000017500000000000006216025074015430 5ustar andreasandreasarpack-akloeckner-07/LAPACK/cgbtf2.f0000644000175000017500000001420406153460156016753 0ustar andreasandreas SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 2.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, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX AB( LDAB, * ) * .. * * Purpose * ======= * * CGBTF2 computes an LU factorization of a complex m-by-n band matrix * A using partial pivoting with row interchanges. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) COMPLEX array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U, because of fill-in resulting from the row * interchanges. * * ===================================================================== * * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, JP, JU, KM, KV * .. * .. External Functions .. INTEGER ICAMAX EXTERNAL ICAMAX * .. * .. External Subroutines .. EXTERNAL CGERU, CSCAL, CSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in. * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGBTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero. * DO 20 J = KU + 2, MIN( KV, N ) DO 10 I = KV - J + 2, KL AB( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * JU is the index of the last column affected by the current stage * of the factorization. * JU = 1 * DO 40 J = 1, MIN( M, N ) * * Set fill-in elements in column J+KV to zero. * IF( J+KV.LE.N ) THEN DO 30 I = 1, KL AB( I, J+KV ) = ZERO 30 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-J ) JP = ICAMAX( KM+1, AB( KV+1, J ), 1 ) IPIV( J ) = JP + J - 1 IF( AB( KV+JP, J ).NE.ZERO ) THEN JU = MAX( JU, MIN( J+KU+JP-1, N ) ) * * Apply interchange to columns J to JU. * IF( JP.NE.1 ) $ CALL CSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, $ AB( KV+1, J ), LDAB-1 ) IF( KM.GT.0 ) THEN * * Compute multipliers. * CALL CSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) * * Update trailing submatrix within the band. * IF( JU.GT.J ) $ CALL CGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1, $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), $ LDAB-1 ) END IF ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = J END IF 40 CONTINUE RETURN * * End of CGBTF2 * END arpack-akloeckner-07/LAPACK/cgbtrf.f0000644000175000017500000003436606153460156017066 0ustar andreasandreas SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 2.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, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX AB( LDAB, * ) * .. * * Purpose * ======= * * CGBTRF computes an LU factorization of a complex m-by-n band matrix A * using partial pivoting with row interchanges. * * This is the blocked version of the algorithm, calling Level 3 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) COMPLEX array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U because of fill-in resulting from the row interchanges. * * ===================================================================== * * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) INTEGER NBMAX, LDWORK PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) * .. * .. Local Scalars .. INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, $ JU, K2, KM, KV, NB, NW COMPLEX TEMP * .. * .. Local Arrays .. COMPLEX WORK13( LDWORK, NBMAX ), $ WORK31( LDWORK, NBMAX ) * .. * .. External Functions .. INTEGER ICAMAX, ILAENV EXTERNAL ICAMAX, ILAENV * .. * .. External Subroutines .. EXTERNAL CCOPY, CGBTF2, CGEMM, CGERU, CLASWP, CSCAL, $ CSWAP, CTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGBTRF', -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 = ILAENV( 1, 'CGBTRF', ' ', M, N, KL, KU ) * * The block size must not exceed the limit set by the size of the * local arrays WORK13 and WORK31. * NB = MIN( NB, NBMAX ) * IF( NB.LE.1 .OR. NB.GT.KL ) THEN * * Use unblocked code * CALL CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) ELSE * * Use blocked code * * Zero the superdiagonal elements of the work array WORK13 * DO 20 J = 1, NB DO 10 I = 1, J - 1 WORK13( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * Zero the subdiagonal elements of the work array WORK31 * DO 40 J = 1, NB DO 30 I = J + 1, NB WORK31( I, J ) = ZERO 30 CONTINUE 40 CONTINUE * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero * DO 60 J = KU + 2, MIN( KV, N ) DO 50 I = KV - J + 2, KL AB( I, J ) = ZERO 50 CONTINUE 60 CONTINUE * * JU is the index of the last column affected by the current * stage of the factorization * JU = 1 * DO 180 J = 1, MIN( M, N ), NB JB = MIN( NB, MIN( M, N )-J+1 ) * * The active part of the matrix is partitioned * * A11 A12 A13 * A21 A22 A23 * A31 A32 A33 * * Here A11, A21 and A31 denote the current block of JB columns * which is about to be factorized. The number of rows in the * partitioning are JB, I2, I3 respectively, and the numbers * of columns are JB, J2, J3. The superdiagonal elements of A13 * and the subdiagonal elements of A31 lie outside the band. * I2 = MIN( KL-JB, M-J-JB+1 ) I3 = MIN( JB, M-J-KL+1 ) * * J2 and J3 are computed after JU has been updated. * * Factorize the current block of JB columns * DO 80 JJ = J, J + JB - 1 * * Set fill-in elements in column JJ+KV to zero * IF( JJ+KV.LE.N ) THEN DO 70 I = 1, KL AB( I, JJ+KV ) = ZERO 70 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-JJ ) JP = ICAMAX( KM+1, AB( KV+1, JJ ), 1 ) IPIV( JJ ) = JP + JJ - J IF( AB( KV+JP, JJ ).NE.ZERO ) THEN JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) IF( JP.NE.1 ) THEN * * Apply interchange to columns J to J+JB-1 * IF( JP+JJ-1.LT.J+KL ) THEN * CALL CSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange affects columns J to JJ-1 of A31 * which are stored in the work array WORK31 * CALL CSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) CALL CSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, $ AB( KV+JP, JJ ), LDAB-1 ) END IF END IF * * Compute multipliers * CALL CSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), $ 1 ) * * Update trailing submatrix within the band and within * the current block. JM is the index of the last column * which needs to be updated. * JM = MIN( JU, J+JB-1 ) IF( JM.GT.JJ ) $ CALL CGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, $ AB( KV, JJ+1 ), LDAB-1, $ AB( KV+1, JJ+1 ), LDAB-1 ) ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = JJ END IF * * Copy current column of A31 into the work array WORK31 * NW = MIN( JJ-J+1, I3 ) IF( NW.GT.0 ) $ CALL CCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, $ WORK31( 1, JJ-J+1 ), 1 ) 80 CONTINUE IF( J+JB.LE.N ) THEN * * Apply the row interchanges to the other blocks. * J2 = MIN( JU-J+1, KV ) - JB J3 = MAX( 0, JU-J-KV+1 ) * * Use CLASWP to apply the row interchanges to A12, A22, and * A32. * CALL CLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, $ IPIV( J ), 1 ) * * Adjust the pivot indices. * DO 90 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 90 CONTINUE * * Apply the row interchanges to A13, A23, and A33 * columnwise. * K2 = J - 1 + JB + J2 DO 110 I = 1, J3 JJ = K2 + I DO 100 II = J + I - 1, J + JB - 1 IP = IPIV( II ) IF( IP.NE.II ) THEN TEMP = AB( KV+1+II-JJ, JJ ) AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) AB( KV+1+IP-JJ, JJ ) = TEMP END IF 100 CONTINUE 110 CONTINUE * * Update the relevant part of the trailing submatrix * IF( J2.GT.0 ) THEN * * Update A12 * CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1 ) * IF( I2.GT.0 ) THEN * * Update A22 * CALL CGEMM( 'No transpose', 'No transpose', I2, J2, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+1, J+JB ), LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A32 * CALL CGEMM( 'No transpose', 'No transpose', I3, J2, $ JB, -ONE, WORK31, LDWORK, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) END IF END IF * IF( J3.GT.0 ) THEN * * Copy the lower triangle of A13 into the work array * WORK13 * DO 130 JJ = 1, J3 DO 120 II = JJ, JB WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) 120 CONTINUE 130 CONTINUE * * Update A13 in the work array * CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, $ WORK13, LDWORK ) * IF( I2.GT.0 ) THEN * * Update A23 * CALL CGEMM( 'No transpose', 'No transpose', I2, J3, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), $ LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A33 * CALL CGEMM( 'No transpose', 'No transpose', I3, J3, $ JB, -ONE, WORK31, LDWORK, WORK13, $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) END IF * * Copy the lower triangle of A13 back into place * DO 150 JJ = 1, J3 DO 140 II = JJ, JB AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) 140 CONTINUE 150 CONTINUE END IF ELSE * * Adjust the pivot indices. * DO 160 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 160 CONTINUE END IF * * Partially undo the interchanges in the current block to * restore the upper triangular form of A31 and copy the upper * triangle of A31 back into place * DO 170 JJ = J + JB - 1, J, -1 JP = IPIV( JJ ) - JJ + 1 IF( JP.NE.1 ) THEN * * Apply interchange to columns J to JJ-1 * IF( JP+JJ-1.LT.J+KL ) THEN * * The interchange does not affect A31 * CALL CSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange does affect A31 * CALL CSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) END IF END IF * * Copy the current column of A31 back into place * NW = MIN( I3, JJ-J+1 ) IF( NW.GT.0 ) $ CALL CCOPY( NW, WORK31( 1, JJ-J+1 ), 1, $ AB( KV+KL+1-JJ+J, JJ ), 1 ) 170 CONTINUE 180 CONTINUE END IF * RETURN * * End of CGBTRF * END arpack-akloeckner-07/LAPACK/cgbtrs.f0000644000175000017500000001453106153460156017073 0ustar andreasandreas SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 2.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, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX AB( LDAB, * ), B( LDB, * ) * .. * * Purpose * ======= * * CGBTRS solves a system of linear equations * A * X = B, A**T * X = B, or A**H * X = B * with a general band matrix A using the LU factorization computed * by CGBTRF. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * AB (input) COMPLEX array, dimension (LDAB,N) * Details of the LU factorization of the band matrix A, as * computed by CGBTRF. U is stored as an upper triangular band * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and * the multipliers used during the factorization are stored in * rows KL+KU+2 to 2*KL+KU+1. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; 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 LNOTI, NOTRAN INTEGER I, J, KD, L, LM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CGEMV, CGERU, CLACGV, CSWAP, CTBSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. 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( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGBTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * KD = KU + KL + 1 LNOTI = KL.GT.0 * IF( NOTRAN ) THEN * * Solve A*X = B. * * Solve L*X = B, overwriting B with X. * * L is represented as a product of permutations and unit lower * triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), * where each transformation L(i) is a rank-one modification of * the identity matrix. * IF( LNOTI ) THEN DO 10 J = 1, N - 1 LM = MIN( KL, N-J ) L = IPIV( J ) IF( L.NE.J ) $ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) CALL CGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), $ LDB, B( J+1, 1 ), LDB ) 10 CONTINUE END IF * DO 20 I = 1, NRHS * * Solve U*X = B, overwriting B with X. * CALL CTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, $ AB, LDAB, B( 1, I ), 1 ) 20 CONTINUE * ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * X = B. * DO 30 I = 1, NRHS * * Solve U**T * X = B, overwriting B with X. * CALL CTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, $ LDAB, B( 1, I ), 1 ) 30 CONTINUE * * Solve L**T * X = B, overwriting B with X. * IF( LNOTI ) THEN DO 40 J = N - 1, 1, -1 LM = MIN( KL, N-J ) CALL CGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) L = IPIV( J ) IF( L.NE.J ) $ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 40 CONTINUE END IF * ELSE * * Solve A**H * X = B. * DO 50 I = 1, NRHS * * Solve U**H * X = B, overwriting B with X. * CALL CTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N, $ KL+KU, AB, LDAB, B( 1, I ), 1 ) 50 CONTINUE * * Solve L**H * X = B, overwriting B with X. * IF( LNOTI ) THEN DO 60 J = N - 1, 1, -1 LM = MIN( KL, N-J ) CALL CLACGV( NRHS, B( J, 1 ), LDB ) CALL CGEMV( 'Conjugate transpose', LM, NRHS, -ONE, $ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE, $ B( J, 1 ), LDB ) CALL CLACGV( NRHS, B( J, 1 ), LDB ) L = IPIV( J ) IF( L.NE.J ) $ CALL CSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 60 CONTINUE END IF END IF RETURN * * End of CGBTRS * END arpack-akloeckner-07/LAPACK/cgeqr2.f0000644000175000017500000000652106153460156016772 0ustar andreasandreas SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 2.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 .. COMPLEX A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * CGEQR2 computes a QR factorization of a complex m by n matrix A: * A = Q * R. * * 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 A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX ALPHA * .. * .. External Subroutines .. EXTERNAL CLARF, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * 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( 'CGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL CLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i)' to A(i:m,i+1:n) from the left * ALPHA = A( I, I ) A( I, I ) = ONE CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = ALPHA END IF 10 CONTINUE RETURN * * End of CGEQR2 * END arpack-akloeckner-07/LAPACK/cgttrf.f0000644000175000017500000001113506153460156017075 0ustar andreasandreas SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * * -- LAPACK routine (version 2.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, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * CGTTRF computes an LU factorization of a complex tridiagonal matrix A * using elimination with partial pivoting and row interchanges. * * The factorization has the form * A = L * U * where L is a product of permutation and unit lower bidiagonal * matrices and U is upper triangular with nonzeros in only the main * diagonal and first two superdiagonals. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * DL (input/output) COMPLEX array, dimension (N-1) * On entry, DL must contain the (n-1) subdiagonal elements of * A. * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) COMPLEX array, dimension (N) * On entry, D must contain the diagonal elements of A. * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) COMPLEX array, dimension (N-1) * On entry, DU must contain the (n-1) superdiagonal elements * of A. * On exit, DU is overwritten by the (n-1) elements of the first * superdiagonal of U. * * DU2 (output) COMPLEX array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the * second superdiagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * 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. * * ===================================================================== * * .. Local Scalars .. INTEGER I COMPLEX FACT, TEMP, ZDUM * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Parameters .. COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'CGTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Initialize IPIV(i) = i * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE * DO 20 I = 1, N - 1 IF( DL( I ).EQ.CZERO ) THEN * * Subdiagonal is zero, no elimination is required. * IF( D( I ).EQ.CZERO .AND. INFO.EQ.0 ) $ INFO = I IF( I.LT.N-1 ) $ DU2( I ) = CZERO ELSE IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * FACT = DL( I ) / D( I ) DL( I ) = FACT D( I+1 ) = D( I+1 ) - FACT*DU( I ) IF( I.LT.N-1 ) $ DU2( I ) = CZERO ELSE * * Interchange rows I and I+1, eliminate DL(I) * FACT = D( I ) / DL( I ) D( I ) = DL( I ) DL( I ) = FACT TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) IF( I.LT.N-1 ) THEN DU2( I ) = DU( I+1 ) DU( I+1 ) = -FACT*DU( I+1 ) END IF IPIV( I ) = IPIV( I ) + 1 END IF 20 CONTINUE IF( D( N ).EQ.CZERO .AND. INFO.EQ.0 ) THEN INFO = N RETURN END IF * RETURN * * End of CGTTRF * END arpack-akloeckner-07/LAPACK/cgttrs.f0000644000175000017500000001414506153460156017116 0ustar andreasandreas SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 2.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, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * CGTTRS solves one of the systems of equations * A * X = B, A**T * X = B, or A**H * X = B, * with a tridiagonal matrix A using the LU factorization computed * by CGTTRF. * * Arguments * ========= * * TRANS (input) CHARACTER * 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. * * DL (input) COMPLEX array, dimension (N-1) * The (n-1) multipliers that define the matrix L from the * LU factorization of A. * * D (input) COMPLEX array, dimension (N) * The n diagonal elements of the upper triangular matrix U from * the LU factorization of A. * * DU (input) COMPLEX array, dimension (N-1) * The (n-1) elements of the first superdiagonal of U. * * DU2 (input) COMPLEX array, dimension (N-2) * The (n-2) elements of the second superdiagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * B (input/output) COMPLEX array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, B is overwritten by 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 * * ===================================================================== * * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, J COMPLEX TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * 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( LDB.LT.MAX( N, 1 ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CGTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A*X = B using the LU factorization of A, * overwriting each right hand side vector with its solution. * DO 30 J = 1, NRHS * * Solve L*x = b. * DO 10 I = 1, N - 1 IF( IPIV( I ).EQ.I ) THEN B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) ELSE TEMP = B( I, J ) B( I, J ) = B( I+1, J ) B( I+1, J ) = TEMP - DL( I )*B( I, J ) END IF 10 CONTINUE * * Solve U*x = b. * B( N, J ) = B( N, J ) / D( N ) IF( N.GT.1 ) $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / $ D( N-1 ) DO 20 I = N - 2, 1, -1 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* $ B( I+2, J ) ) / D( I ) 20 CONTINUE 30 CONTINUE ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * X = B. * DO 60 J = 1, NRHS * * Solve U**T * x = b. * B( 1, J ) = B( 1, J ) / D( 1 ) IF( N.GT.1 ) $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) DO 40 I = 3, N B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* $ B( I-2, J ) ) / D( I ) 40 CONTINUE * * Solve L**T * x = b. * DO 50 I = N - 1, 1, -1 IF( IPIV( I ).EQ.I ) THEN B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) ELSE TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - DL( I )*TEMP B( I, J ) = TEMP END IF 50 CONTINUE 60 CONTINUE ELSE * * Solve A**H * X = B. * DO 90 J = 1, NRHS * * Solve U**H * x = b. * B( 1, J ) = B( 1, J ) / CONJG( D( 1 ) ) IF( N.GT.1 ) $ B( 2, J ) = ( B( 2, J )-CONJG( DU( 1 ) )*B( 1, J ) ) / $ CONJG( D( 2 ) ) DO 70 I = 3, N B( I, J ) = ( B( I, J )-CONJG( DU( I-1 ) )*B( I-1, J )- $ CONJG( DU2( I-2 ) )*B( I-2, J ) ) / $ CONJG( D( I ) ) 70 CONTINUE * * Solve L**H * x = b. * DO 80 I = N - 1, 1, -1 IF( IPIV( I ).EQ.I ) THEN B( I, J ) = B( I, J ) - CONJG( DL( I ) )*B( I+1, J ) ELSE TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - CONJG( DL( I ) )*TEMP B( I, J ) = TEMP END IF 80 CONTINUE 90 CONTINUE END IF * * End of CGTTRS * END arpack-akloeckner-07/LAPACK/clacgv.f0000644000175000017500000000272306153460157017047 0ustar andreasandreas SUBROUTINE CLACGV( N, X, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX X( * ) * .. * * Purpose * ======= * * CLACGV conjugates a complex vector of length N. * * Arguments * ========= * * N (input) INTEGER * The length of the vector X. N >= 0. * * X (input/output) COMPLEX array, dimension * (1+(N-1)*abs(INCX)) * On entry, the vector of length N to be conjugated. * On exit, X is overwritten with conjg(X). * * INCX (input) INTEGER * The spacing between successive elements of X. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IOFF * .. * .. Intrinsic Functions .. INTRINSIC CONJG * .. * .. Executable Statements .. * IF( INCX.EQ.1 ) THEN DO 10 I = 1, N X( I ) = CONJG( X( I ) ) 10 CONTINUE ELSE IOFF = 1 IF( INCX.LT.0 ) $ IOFF = 1 - ( N-1 )*INCX DO 20 I = 1, N X( IOFF ) = CONJG( X( IOFF ) ) IOFF = IOFF + INCX 20 CONTINUE END IF RETURN * * End of CLACGV * END arpack-akloeckner-07/LAPACK/clacon.f0000644000175000017500000001234106153460157017044 0ustar andreasandreas SUBROUTINE CLACON( N, V, X, EST, KASE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER KASE, N REAL EST * .. * .. Array Arguments .. COMPLEX V( N ), X( N ) * .. * * Purpose * ======= * * CLACON estimates the 1-norm of a square, complex matrix A. * Reverse communication is used for evaluating matrix-vector products. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix. N >= 1. * * V (workspace) COMPLEX array, dimension (N) * On the final return, V = A*W, where EST = norm(V)/norm(W) * (W is not returned). * * X (input/output) COMPLEX array, dimension (N) * On an intermediate return, X should be overwritten by * A * X, if KASE=1, * A' * X, if KASE=2, * where A' is the conjugate transpose of A, and CLACON must be * re-called with all the other parameters unchanged. * * EST (output) REAL * An estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to CLACON, KASE should be 0. * On an intermediate return, KASE will be 1 or 2, indicating * whether X should be overwritten by A * X or A' * X. * On the final return from CLACON, KASE will again be 0. * * Further Details * ======= ======= * * Contributed by Nick Higham, University of Manchester. * Originally named CONEST, dated March 16, 1988. * * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of * a real or complex matrix, with applications to condition estimation", * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) REAL ONE, TWO PARAMETER ( ONE = 1.0E0, TWO = 2.0E0 ) COMPLEX CZERO, CONE PARAMETER ( CZERO = ( 0.0E0, 0.0E0 ), $ CONE = ( 1.0E0, 0.0E0 ) ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP REAL ALTSGN, ESTOLD, SAFMIN, TEMP * .. * .. External Functions .. INTEGER ICMAX1 REAL SCSUM1, SLAMCH EXTERNAL ICMAX1, SCSUM1, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, REAL * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * SAFMIN = SLAMCH( 'Safe minimum' ) IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = CMPLX( ONE / REAL( N ) ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 90, 120 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 130 END IF EST = SCSUM1( N, X, 1 ) * DO 30 I = 1, N IF( ABS( X( I ) ).GT.SAFMIN ) THEN X( I ) = X( I ) / CMPLX( ABS( X( I ) ) ) ELSE X( I ) = CONE END IF 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 40 CONTINUE J = ICMAX1( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = CZERO 60 CONTINUE X( J ) = CONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL CCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = SCSUM1( N, V, 1 ) * * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 100 * DO 80 I = 1, N IF( ABS( X( I ) ).GT.SAFMIN ) THEN X( I ) = X( I ) / CMPLX( ABS( X( I ) ) ) ELSE X( I ) = CONE END IF 80 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. * 90 CONTINUE JLAST = J J = ICMAX1( N, X, 1 ) IF( ( REAL( X( JLAST ) ).NE.ABS( REAL( X( J ) ) ) ) .AND. $ ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 100 CONTINUE ALTSGN = ONE DO 110 I = 1, N X( I ) = CMPLX( ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) ) ) ALTSGN = -ALTSGN 110 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 120 CONTINUE TEMP = TWO*( SCSUM1( N, X, 1 ) / REAL( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL CCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 130 CONTINUE KASE = 0 RETURN * * End of CLACON * END arpack-akloeckner-07/LAPACK/clacpy.f0000644000175000017500000000456206153460157017066 0ustar andreasandreas SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 2.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 LDA, LDB, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * CLACPY copies all or part of a two-dimensional matrix A to another * matrix B. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be copied to B. * = 'U': Upper triangular part * = 'L': Lower triangular part * Otherwise: All of the matrix A * * 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) COMPLEX array, dimension (LDA,N) * The m by n matrix A. If UPLO = 'U', only the upper trapezium * is accessed; if UPLO = 'L', only the lower trapezium is * accessed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (output) COMPLEX array, dimension (LDB,N) * On exit, B = A in the locations specified by UPLO. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE * ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF * RETURN * * End of CLACPY * END arpack-akloeckner-07/LAPACK/cladiv.f0000644000175000017500000000214706153460157017052 0ustar andreasandreas COMPLEX FUNCTION CLADIV( X, Y ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. COMPLEX X, Y * .. * * Purpose * ======= * * CLADIV := X / Y, where X and Y are complex. The computation of X / Y * will not overflow on an intermediary step unless the results * overflows. * * Arguments * ========= * * X (input) COMPLEX * Y (input) COMPLEX * The complex scalars X and Y. * * ===================================================================== * * .. Local Scalars .. REAL ZI, ZR * .. * .. External Subroutines .. EXTERNAL SLADIV * .. * .. Intrinsic Functions .. INTRINSIC AIMAG, CMPLX, REAL * .. * .. Executable Statements .. * CALL SLADIV( REAL( X ), AIMAG( X ), REAL( Y ), AIMAG( Y ), ZR, $ ZI ) CLADIV = CMPLX( ZR, ZI ) * RETURN * * End of CLADIV * END arpack-akloeckner-07/LAPACK/clahqr.f0000644000175000017500000003001006153460157017050 0ustar andreasandreas SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. LOGICAL WANTT, WANTZ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. COMPLEX H( LDH, * ), W( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * CLAHQR is an auxiliary routine called by CHSEQR to update the * eigenvalues and Schur decomposition already computed by CHSEQR, by * dealing with the Hessenberg submatrix in rows and columns ILO to IHI. * * Arguments * ========= * * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * * N (input) INTEGER * The order of the matrix H. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows and * columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). * CLAHQR works primarily with the Hessenberg submatrix in rows * and columns ILO to IHI, but applies transformations to all of * H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * * H (input/output) COMPLEX array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if WANTT is .TRUE., H is upper triangular in rows * and columns ILO:IHI, with any 2-by-2 diagonal blocks in * standard form. If WANTT is .FALSE., the contents of H are * unspecified on exit. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * * W (output) COMPLEX array, dimension (N) * The computed eigenvalues ILO to IHI are stored in the * corresponding elements of W. If WANTT is .TRUE., the * eigenvalues are stored in the same order as on the diagonal * of the Schur form returned in H, with W(i) = H(i,i). * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * * Z (input/output) COMPLEX array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by CHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * > 0: if INFO = i, CLAHQR failed to compute all the * eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1) * iterations; elements i+1:ihi of W contain those * eigenvalues which have been successfully computed. * * ===================================================================== * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) REAL RZERO, HALF PARAMETER ( RZERO = 0.0E+0, HALF = 0.5E+0 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NZ REAL H10, H21, RTEMP, S, SMLNUM, T2, TST1, ULP COMPLEX CDUM, H11, H11S, H22, SUM, T, T1, TEMP, U, V2, $ X, Y * .. * .. Local Arrays .. REAL RWORK( 1 ) COMPLEX V( 2 ) * .. * .. External Functions .. REAL CLANHS, SLAMCH COMPLEX CLADIV EXTERNAL CLANHS, SLAMCH, CLADIV * .. * .. External Subroutines .. EXTERNAL CCOPY, CLARFG, CSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CONJG, MAX, MIN, REAL, SQRT * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN W( ILO ) = H( ILO, ILO ) RETURN END IF * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * If norm(H) <= sqrt(OVFL), overflow should not occur. * ULP = SLAMCH( 'Precision' ) SMLNUM = SLAMCH( 'Safe minimum' ) / ULP * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITN is the total number of QR iterations allowed. * ITN = 30*NH * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1. Each iteration of the loop works * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 10 CONTINUE IF( I.LT.ILO ) $ GO TO 130 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 splits off at the bottom because a * subdiagonal element has become negligible. * L = ILO DO 110 ITS = 0, ITN * * Look for a single small subdiagonal element. * DO 20 K = I, L + 1, -1 TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) IF( TST1.EQ.RZERO ) $ TST1 = CLANHS( '1', I-L+1, H( L, L ), LDH, RWORK ) IF( ABS( REAL( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) ) $ GO TO 30 20 CONTINUE 30 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 has split off. * IF( L.GE.I ) $ GO TO 120 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN * * Exceptional shift. * T = ABS( REAL( H( I, I-1 ) ) ) + $ ABS( REAL( H( I-1, I-2 ) ) ) ELSE * * Wilkinson's shift. * T = H( I, I ) U = H( I-1, I )*REAL( H( I, I-1 ) ) IF( U.NE.ZERO ) THEN X = HALF*( H( I-1, I-1 )-T ) Y = SQRT( X*X+U ) IF( REAL( X )*REAL( Y )+AIMAG( X )*AIMAG( Y ).LT.RZERO ) $ Y = -Y T = T - CLADIV( U, ( X+Y ) ) END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 40 M = I - 1, L + 1, -1 * * Determine the effect of starting the single-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. * H11 = H( M, M ) H22 = H( M+1, M+1 ) H11S = H11 - T H21 = H( M+1, M ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 H10 = H( M, M-1 ) TST1 = CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) IF( ABS( H10*H21 ).LE.ULP*TST1 ) $ GO TO 50 40 CONTINUE H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T H21 = H( L+1, L ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 50 CONTINUE * * Single-shift QR step * DO 100 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. * * V(2) is always real before the call to CLARFG, and hence * after the call T2 ( = T1*V(2) ) is also real. * IF( K.GT.M ) $ CALL CCOPY( 2, H( K, K-1 ), 1, V, 1 ) CALL CLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO END IF V2 = V( 2 ) T2 = REAL( T1*V2 ) * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 60 J = K, I2 SUM = CONJG( T1 )*H( K, J ) + T2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM H( K+1, J ) = H( K+1, J ) - SUM*V2 60 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+2,I). * DO 70 J = I1, MIN( K+2, I ) SUM = T1*H( J, K ) + T2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM H( J, K+1 ) = H( J, K+1 ) - SUM*CONJG( V2 ) 70 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 80 J = ILOZ, IHIZ SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM Z( J, K+1 ) = Z( J, K+1 ) - SUM*CONJG( V2 ) 80 CONTINUE END IF * IF( K.EQ.M .AND. M.GT.L ) THEN * * If the QR step was started at row M > L because two * consecutive small subdiagonals were found, then extra * scaling must be performed to ensure that H(M,M-1) remains * real. * TEMP = ONE - T1 TEMP = TEMP / ABS( TEMP ) H( M+1, M ) = H( M+1, M )*CONJG( TEMP ) IF( M+2.LE.I ) $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP DO 90 J = M, I IF( J.NE.M+1 ) THEN IF( I2.GT.J ) $ CALL CSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) CALL CSCAL( J-I1, CONJG( TEMP ), H( I1, J ), 1 ) IF( WANTZ ) THEN CALL CSCAL( NZ, CONJG( TEMP ), Z( ILOZ, J ), 1 ) END IF END IF 90 CONTINUE END IF 100 CONTINUE * * Ensure that H(I,I-1) is real. * TEMP = H( I, I-1 ) IF( AIMAG( TEMP ).NE.RZERO ) THEN RTEMP = ABS( TEMP ) H( I, I-1 ) = RTEMP TEMP = TEMP / RTEMP IF( I2.GT.I ) $ CALL CSCAL( I2-I, CONJG( TEMP ), H( I, I+1 ), LDH ) CALL CSCAL( I-I1, TEMP, H( I1, I ), 1 ) IF( WANTZ ) THEN CALL CSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) END IF END IF * 110 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 120 CONTINUE * * H(I,I-1) is negligible: one eigenvalue has converged. * W( I ) = H( I, I ) * * Decrement number of remaining iterations, and return to start of * the main loop with new value of I. * ITN = ITN - ITS I = L - 1 GO TO 10 * 130 CONTINUE RETURN * * End of CLAHQR * END arpack-akloeckner-07/LAPACK/clange.f0000644000175000017500000000766406153460157017052 0ustar andreasandreas REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N * .. * .. Array Arguments .. REAL WORK( * ) COMPLEX A( LDA, * ) * .. * * Purpose * ======= * * CLANGE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * complex matrix A. * * Description * =========== * * CLANGE returns the value * * CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in CLANGE as described * above. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. When M = 0, * CLANGE is set to zero. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. When N = 0, * CLANGE is set to zero. * * A (input) COMPLEX array, dimension (LDA,N) * The m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * * WORK (workspace) REAL array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, M SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, M WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, M VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL CLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * CLANGE = VALUE RETURN * * End of CLANGE * END arpack-akloeckner-07/LAPACK/clanhs.f0000644000175000017500000000764106153460157017064 0ustar andreasandreas REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N * .. * .. Array Arguments .. REAL WORK( * ) COMPLEX A( LDA, * ) * .. * * Purpose * ======= * * CLANHS returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * Hessenberg matrix A. * * Description * =========== * * CLANHS returns the value * * CLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in CLANHS as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, CLANHS is * set to zero. * * A (input) COMPLEX array, dimension (LDA,N) * The n by n upper Hessenberg matrix A; the part of A below the * first sub-diagonal is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) REAL array, dimension (LWORK), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL CLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * CLANHS = VALUE RETURN * * End of CLANHS * END arpack-akloeckner-07/LAPACK/clarf.f0000644000175000017500000000625306153460157016701 0ustar andreasandreas SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N COMPLEX TAU * .. * .. Array Arguments .. COMPLEX C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * CLARF applies a complex elementary reflector H to a complex M-by-N * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a complex scalar and v is a complex vector. * * If tau = 0, then H is taken to be the unit matrix. * * To apply H' (the conjugate transpose of H), supply conjg(tau) instead * tau. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) COMPLEX array, dimension * (1 + (M-1)*abs(INCV)) if SIDE = 'L' * or (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of H. V is not used if * TAU = 0. * * INCV (input) INTEGER * The increment between elements of v. INCV <> 0. * * TAU (input) COMPLEX * The value tau in the representation of H. * * C (input/output) COMPLEX array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. External Subroutines .. EXTERNAL CGEMV, CGERC * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w := C' * v * CALL CGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, $ INCV, ZERO, WORK, 1 ) * * C := C - v * w' * CALL CGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w := C * v * CALL CGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - w * v' * CALL CGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of CLARF * END arpack-akloeckner-07/LAPACK/clarfg.f0000644000175000017500000000775306153460157017056 0ustar andreasandreas SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N COMPLEX ALPHA, TAU * .. * .. Array Arguments .. COMPLEX X( * ) * .. * * Purpose * ======= * * CLARFG generates a complex elementary reflector H of order n, such * that * * H' * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, with beta real, and x is an * (n-1)-element complex vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a complex scalar and v is a complex (n-1)-element * vector. Note that H is not hermitian. * * If the elements of x are all zero and alpha is real, then tau = 0 * and H is taken to be the unit matrix. * * Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) COMPLEX * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) COMPLEX array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX > 0. * * TAU (output) COMPLEX * The value tau. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER J, KNT REAL ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. REAL SCNRM2, SLAMCH, SLAPY3 COMPLEX CLADIV EXTERNAL SCNRM2, SLAMCH, SLAPY3, CLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, REAL, SIGN * .. * .. External Subroutines .. EXTERNAL CSCAL, CSSCAL * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN TAU = ZERO RETURN END IF * XNORM = SCNRM2( N-1, X, INCX ) ALPHR = REAL( ALPHA ) ALPHI = AIMAG( ALPHA ) * IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' ) RSAFMN = ONE / SAFMIN * IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * KNT = 0 10 CONTINUE KNT = KNT + 1 CALL CSSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHI = ALPHI*RSAFMN ALPHR = ALPHR*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = SCNRM2( N-1, X, INCX ) ALPHA = CMPLX( ALPHR, ALPHI ) BETA = -SIGN( SLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA ) CALL CSCAL( N-1, ALPHA, X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = CMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = CLADIV( CMPLX( ONE ), ALPHA-BETA ) CALL CSCAL( N-1, ALPHA, X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of CLARFG * END arpack-akloeckner-07/LAPACK/clarnv.f0000644000175000017500000000772206153460157017101 0ustar andreasandreas SUBROUTINE CLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX X( * ) * .. * * Purpose * ======= * * CLARNV returns a vector of n random complex numbers from a uniform or * normal distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: real and imaginary parts each uniform (0,1) * = 2: real and imaginary parts each uniform (-1,1) * = 3: real and imaginary parts each normal (0,1) * = 4: uniformly distributed on the disc abs(z) < 1 * = 5: uniformly distributed on the circle abs(z) = 1 * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * N (input) INTEGER * The number of random numbers to be generated. * * X (output) COMPLEX array, dimension (N) * The generated random numbers. * * Further Details * =============== * * This routine calls the auxiliary routine SLARUV to generate random * real numbers from a uniform (0,1) distribution, in batches of up to * 128 using vectorisable code. The Box-Muller method is used to * transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) INTEGER LV PARAMETER ( LV = 128 ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IV * .. * .. Local Arrays .. REAL U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC CMPLX, EXP, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL SLARUV * .. * .. Executable Statements .. * DO 60 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) * * Call SLARUV to generate 2*IL real numbers from a uniform (0,1) * distribution (2*IL <= LV) * CALL SLARUV( ISEED, 2*IL, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = CMPLX( U( 2*I-1 ), U( 2*I ) ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = CMPLX( TWO*U( 2*I-1 )-ONE, $ TWO*U( 2*I )-ONE ) 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) ) 30 CONTINUE ELSE IF( IDIST.EQ.4 ) THEN * * Convert generated numbers to complex numbers uniformly * distributed on the unit disk * DO 40 I = 1, IL X( IV+I-1 ) = SQRT( U( 2*I-1 ) )* $ EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) ) 40 CONTINUE ELSE IF( IDIST.EQ.5 ) THEN * * Convert generated numbers to complex numbers uniformly * distributed on the unit circle * DO 50 I = 1, IL X( IV+I-1 ) = EXP( CMPLX( ZERO, TWOPI*U( 2*I ) ) ) 50 CONTINUE END IF 60 CONTINUE RETURN * * End of CLARNV * END arpack-akloeckner-07/LAPACK/clartg.f0000644000175000017500000000600606153460157017062 0ustar andreasandreas SUBROUTINE CLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. REAL CS COMPLEX F, G, R, SN * .. * * Purpose * ======= * * CLARTG generates a plane rotation so that * * [ CS SN ] [ F ] [ R ] * [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. * [ -SN CS ] [ G ] [ 0 ] * * This is a faster version of the BLAS1 routine CROTG, except for * the following differences: * F and G are unchanged on return. * If G=0, then CS=1 and SN=0. * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any * floating point operations. * * Arguments * ========= * * F (input) COMPLEX * The first component of vector to be rotated. * * G (input) COMPLEX * The second component of vector to be rotated. * * CS (output) REAL * The cosine of the rotation. * * SN (output) COMPLEX * The sine of the rotation. * * R (output) COMPLEX * The nonzero component of the rotated vector. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) COMPLEX CZERO PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. REAL D, DI, F1, F2, FA, G1, G2, GA COMPLEX FS, GS, SS, T * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CONJG, REAL, SQRT * .. * .. Statement Functions .. REAL ABS1, ABSSQ * .. * .. Statement Function definitions .. ABS1( T ) = ABS( REAL( T ) ) + ABS( AIMAG( T ) ) ABSSQ( T ) = REAL( T )**2 + AIMAG( T )**2 * .. * .. Executable Statements .. * * [ 25 or 38 ops for main paths ] * IF( G.EQ.CZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.CZERO ) THEN CS = ZERO * SN = CONJG( G ) / ABS( G ) R = ABS( G ) * * SN = ONE * R = G * ELSE F1 = ABS1( F ) G1 = ABS1( G ) IF( F1.GE.G1 ) THEN GS = G / F1 G2 = ABSSQ( GS ) FS = F / F1 F2 = ABSSQ( FS ) D = SQRT( ONE+G2 / F2 ) CS = ONE / D SN = CONJG( GS )*FS*( CS / F2 ) R = F*D ELSE FS = F / G1 F2 = ABSSQ( FS ) FA = SQRT( F2 ) GS = G / G1 G2 = ABSSQ( GS ) GA = SQRT( G2 ) D = SQRT( ONE+F2 / G2 ) DI = ONE / D CS = ( FA / GA )*DI SS = ( CONJG( GS )*FS ) / ( FA*GA ) SN = SS*DI R = G*SS*D END IF END IF RETURN * * End of CLARTG * END arpack-akloeckner-07/LAPACK/clascl.f0000644000175000017500000001617206153460160017046 0ustar andreasandreas SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N REAL CFROM, CTO * .. * .. Array Arguments .. COMPLEX A( LDA, * ) * .. * * Purpose * ======= * * CLASCL multiplies the M by N complex matrix A by the real scalar * CTO/CFROM. This is done without over/underflow as long as the final * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that * A may be full, upper triangular, lower triangular, upper Hessenberg, * or banded. * * Arguments * ========= * * TYPE (input) CHARACTER*1 * TYPE indices the storage type of the input matrix. * = 'G': A is a full matrix. * = 'L': A is a lower triangular matrix. * = 'U': A is an upper triangular matrix. * = 'H': A is an upper Hessenberg matrix. * = 'B': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the lower * half stored. * = 'Q': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the upper * half stored. * = 'Z': A is a band matrix with lower bandwidth KL and upper * bandwidth KU. * * KL (input) INTEGER * The lower bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * KU (input) INTEGER * The upper bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * CFROM (input) REAL * CTO (input) REAL * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed * without over/underflow if the final result CTO*A(I,J)/CFROM * can be represented without over/underflow. CFROM must be * nonzero. * * 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,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * INFO (output) INTEGER * 0 - successful exit * <0 - if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH EXTERNAL LSAME, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of CLASCL * END arpack-akloeckner-07/LAPACK/claset.f0000644000175000017500000000606106153460160017054 0ustar andreasandreas SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N COMPLEX ALPHA, BETA * .. * .. Array Arguments .. COMPLEX A( LDA, * ) * .. * * Purpose * ======= * * CLASET initializes a 2-D array A to BETA on the diagonal and * ALPHA on the offdiagonals. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be set. * = 'U': Upper triangular part is set. The lower triangle * is unchanged. * = 'L': Lower triangular part is set. The upper triangle * is unchanged. * Otherwise: All of the matrix A is set. * * M (input) INTEGER * On entry, M specifies the number of rows of A. * * N (input) INTEGER * On entry, N specifies the number of columns of A. * * ALPHA (input) COMPLEX * All the offdiagonal array elements are set to ALPHA. * * BETA (input) COMPLEX * All the diagonal array elements are set to BETA. * * A (input/output) COMPLEX array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; * A(i,i) = BETA , 1 <= i <= min(m,n) * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the diagonal to BETA and the strictly upper triangular * part of the array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( N, M ) A( I, I ) = BETA 30 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the diagonal to BETA and the strictly lower triangular * part of the array to ALPHA. * DO 50 J = 1, MIN( M, N ) DO 40 I = J + 1, M A( I, J ) = ALPHA 40 CONTINUE 50 CONTINUE DO 60 I = 1, MIN( N, M ) A( I, I ) = BETA 60 CONTINUE * ELSE * * Set the array to BETA on the diagonal and ALPHA on the * offdiagonal. * DO 80 J = 1, N DO 70 I = 1, M A( I, J ) = ALPHA 70 CONTINUE 80 CONTINUE DO 90 I = 1, MIN( M, N ) A( I, I ) = BETA 90 CONTINUE END IF * RETURN * * End of CLASET * END arpack-akloeckner-07/LAPACK/classq.f0000644000175000017500000000573606153460160017077 0ustar andreasandreas SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N REAL SCALE, SUMSQ * .. * .. Array Arguments .. COMPLEX X( * ) * .. * * Purpose * ======= * * CLASSQ returns the values scl and ssq such that * * ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, * * where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is * assumed to be at least unity and the value of ssq will then satisfy * * 1.0 .le. ssq .le. ( sumsq + 2*n ). * * scale is assumed to be non-negative and scl returns the value * * scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), * i * * scale and sumsq must be supplied in SCALE and SUMSQ respectively. * SCALE and SUMSQ are overwritten by scl and ssq respectively. * * The routine makes only one pass through the vector X. * * Arguments * ========= * * N (input) INTEGER * The number of elements to be used from the vector X. * * X (input) REAL * The vector x as described above. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. * * INCX (input) INTEGER * The increment between successive values of the vector X. * INCX > 0. * * SCALE (input/output) REAL * On entry, the value scale in the equation above. * On exit, SCALE is overwritten with the value scl . * * SUMSQ (input/output) REAL * On entry, the value sumsq in the equation above. * On exit, SUMSQ is overwritten with the value ssq . * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER IX REAL TEMP1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, REAL * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( REAL( X( IX ) ).NE.ZERO ) THEN TEMP1 = ABS( REAL( X( IX ) ) ) IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF IF( AIMAG( X( IX ) ).NE.ZERO ) THEN TEMP1 = ABS( AIMAG( X( IX ) ) ) IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF 10 CONTINUE END IF * RETURN * * End of CLASSQ * END arpack-akloeckner-07/LAPACK/claswp.f0000644000175000017500000000542006153460160017070 0ustar andreasandreas SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. 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. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IP, IX * .. * .. External Subroutines .. EXTERNAL CSWAP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.EQ.0 ) $ RETURN IF( INCX.GT.0 ) THEN IX = K1 ELSE IX = 1 + ( 1-K2 )*INCX END IF IF( INCX.EQ.1 ) THEN DO 10 I = K1, K2 IP = IPIV( I ) IF( IP.NE.I ) $ CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) 10 CONTINUE ELSE IF( INCX.GT.1 ) THEN DO 20 I = K1, K2 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 20 CONTINUE ELSE IF( INCX.LT.0 ) THEN DO 30 I = K2, K1, -1 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 30 CONTINUE END IF * RETURN * * End of CLASWP * END arpack-akloeckner-07/LAPACK/clatrs.f0000644000175000017500000006672006153460160017101 0ustar andreasandreas SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N REAL SCALE * .. * .. Array Arguments .. REAL CNORM( * ) COMPLEX A( LDA, * ), X( * ) * .. * * Purpose * ======= * * CLATRS solves one of the triangular systems * * A * x = s*b, A**T * x = s*b, or A**H * x = s*b, * * with scaling to prevent overflow. Here A is an upper or lower * triangular matrix, A**T denotes the transpose of A, A**H denotes the * conjugate transpose of A, x and b are n-element vectors, and s is a * scaling factor, usually less than or equal to 1, chosen so that the * components of x will be less than the overflow threshold. If the * unscaled problem will not cause overflow, the Level 2 BLAS routine * CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), * then s is set to 0 and a non-trivial solution to A*x = 0 is returned. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the matrix A is upper or lower triangular. * = 'U': Upper triangular * = 'L': Lower triangular * * TRANS (input) CHARACTER*1 * Specifies the operation applied to A. * = 'N': Solve A * x = s*b (No transpose) * = 'T': Solve A**T * x = s*b (Transpose) * = 'C': Solve A**H * x = s*b (Conjugate transpose) * * DIAG (input) CHARACTER*1 * Specifies whether or not the matrix A is unit triangular. * = 'N': Non-unit triangular * = 'U': Unit triangular * * NORMIN (input) CHARACTER*1 * Specifies whether CNORM has been set or not. * = 'Y': CNORM contains the column norms on entry * = 'N': CNORM is not set on entry. On exit, the norms will * be computed and stored in CNORM. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input) COMPLEX array, dimension (LDA,N) * 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. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max (1,N). * * X (input/output) COMPLEX array, dimension (N) * On entry, the right hand side b of the triangular system. * On exit, X is overwritten by the solution vector x. * * SCALE (output) REAL * The scaling factor s for the triangular system * A * x = s*b, A**T * x = s*b, or A**H * x = s*b. * If SCALE = 0, the matrix A is singular or badly scaled, and * the vector x is an exact or approximate solution to A*x = 0. * * CNORM (input or output) REAL array, dimension (N) * * If NORMIN = 'Y', CNORM is an input argument and CNORM(j) * contains the norm of the off-diagonal part of the j-th column * of A. If TRANS = 'N', CNORM(j) must be greater than or equal * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) * must be greater than or equal to the 1-norm. * * If NORMIN = 'N', CNORM is an output argument and CNORM(j) * returns the 1-norm of the offdiagonal part of the j-th column * of A. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * * Further Details * ======= ======= * * A rough bound on x is computed; if that is less than overflow, CTRSV * is called, otherwise, specific code is used which checks for possible * overflow or divide-by-zero at every operation. * * A columnwise scheme is used for solving A*x = b. The basic algorithm * if A is lower triangular is * * x[1:n] := b[1:n] * for j = 1, ..., n * x(j) := x(j) / A(j,j) * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] * end * * Define bounds on the components of x after j iterations of the loop: * M(j) = bound on x[1:j] * G(j) = bound on x[j+1:n] * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. * * Then for iteration j+1 we have * M(j+1) <= G(j) / | A(j+1,j+1) | * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) * * where CNORM(j+1) is greater than or equal to the infinity-norm of * column j+1 of A, not counting the diagonal. Hence * * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) * 1<=i<=j * and * * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) * 1<=i< j * * Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the * reciprocal of the largest M(j), j=1,..,n, is larger than * max(underflow, 1/overflow). * * The bound on x(j) is also used to determine when a step in the * columnwise method can be performed without fear of overflow. If * the computed bound is greater than a large constant, x is scaled to * prevent overflow, but if the bound overflows, x is set to 0, x(j) to * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. * * Similarly, a row-wise scheme is used to solve A**T *x = b or * A**H *x = b. The basic algorithm for A upper triangular is * * for j = 1, ..., n * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) * end * * We simultaneously compute two bounds * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j * M(j) = bound on x(i), 1<=i<=j * * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. * Then the bound on x(j) is * * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | * * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) * 1<=i<=j * * and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater * than max(underflow, 1/overflow). * * ===================================================================== * * .. Parameters .. REAL ZERO, HALF, ONE, TWO PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0, $ TWO = 2.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST REAL BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, $ XBND, XJ, XMAX COMPLEX CSUMJ, TJJS, USCAL, ZDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ICAMAX, ISAMAX REAL SCASUM, SLAMCH COMPLEX CDOTC, CDOTU, CLADIV EXTERNAL LSAME, ICAMAX, ISAMAX, SCASUM, SLAMCH, CDOTC, $ CDOTU, CLADIV * .. * .. External Subroutines .. EXTERNAL CAXPY, CSSCAL, CTRSV, SLABAD, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, MIN, REAL * .. * .. Statement Functions .. REAL CABS1, CABS2 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) CABS2( ZDUM ) = ABS( REAL( ZDUM ) / 2. ) + $ ABS( AIMAG( ZDUM ) / 2. ) * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = SLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM / SLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = SCASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = SCASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM/2. * IMAX = ISAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM*HALF ) THEN TSCAL = ONE ELSE TSCAL = HALF / ( SMLNUM*TMAX ) CALL SSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine CTRSV can be used. * XMAX = ZERO DO 30 J = 1, N XMAX = MAX( XMAX, CABS2( X( J ) ) ) 30 CONTINUE XBND = XMAX * IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 60 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = G(j-1) / abs(A(j,j)) * XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF * IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 40 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 50 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 50 CONTINUE END IF 60 CONTINUE * ELSE * * Compute the growth in A**T * x = b or A**H * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 90 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF 70 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 80 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 80 CONTINUE END IF 90 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL CTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM*HALF ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = ( BIGNUM*HALF ) / XMAX CALL CSSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM ELSE XMAX = XMAX*TWO END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 110 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 105 END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = CLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = CLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 100 I = 1, N X( I ) = ZERO 100 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 105 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL CSSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL CAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = ICAMAX( J-1, X, 1 ) XMAX = CABS1( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL CAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + ICAMAX( N-J, X( J+1 ), 1 ) XMAX = CABS1( X( I ) ) END IF END IF 110 CONTINUE * ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * x = b * DO 150 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = CLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.CMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call CDOTU to perform the dot product. * IF( UPPER ) THEN CSUMJ = CDOTU( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = CDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 120 I = 1, J - 1 CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 120 CONTINUE ELSE IF( J.LT.N ) THEN DO 130 I = J + 1, N CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 130 CONTINUE END IF END IF * IF( USCAL.EQ.CMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 145 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = CLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = CLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**T *x = 0. * DO 140 I = 1, N X( I ) = ZERO 140 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 145 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = CLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 150 CONTINUE * ELSE * * Solve A**H * x = b * DO 190 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = CONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = CLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.CMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call CDOTC to perform the dot product. * IF( UPPER ) THEN CSUMJ = CDOTC( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = CDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 160 I = 1, J - 1 CSUMJ = CSUMJ + ( CONJG( A( I, J ) )*USCAL )* $ X( I ) 160 CONTINUE ELSE IF( J.LT.N ) THEN DO 170 I = J + 1, N CSUMJ = CSUMJ + ( CONJG( A( I, J ) )*USCAL )* $ X( I ) 170 CONTINUE END IF END IF * IF( USCAL.EQ.CMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = CONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 185 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = CLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL CSSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = CLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**H *x = 0. * DO 180 I = 1, N X( I ) = ZERO 180 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 185 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = CLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 190 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL SSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of CLATRS * END arpack-akloeckner-07/LAPACK/cmach.f0000644000175000017500000000266206153460160016657 0ustar andreasandreas real function cmach(job) integer job c c smach computes machine parameters of floating point c arithmetic for use in testing only. not required by c linpack proper. c c if trouble with automatic computation of these quantities, c they can be set by direct assignment statements. c assume the computer has c c b = base of arithmetic c t = number of base b digits c l = smallest possible exponent c u = largest possible exponent c c then c c eps = b**(1-t) c tiny = 100.0*b**(-l+t) c huge = 0.01*b**(u-t) c c dmach same as smach except t, l, u apply to c double precision. c c cmach same as smach except if complex division c is done by c c 1/(x+i*y) = (x-i*y)/(x**2+y**2) c c then c c tiny = sqrt(tiny) c huge = sqrt(huge) c c c job is 1, 2 or 3 for epsilon, tiny and huge, respectively. c c real eps,tiny,huge,s c eps = 1.0 10 eps = eps/2.0 s = 1.0 + eps if (s .gt. 1.0) go to 10 eps = 2.0*eps cmach =eps if( job .eq. 1) return c s = 1.0 20 tiny = s s = s/16.0 if (s*1.0 .ne. 0.0) go to 20 tiny = (tiny/eps)*100. s = real((1.0,0.0)/cmplx(tiny,0.0)) if (s .ne. 1.0/tiny) tiny = sqrt(tiny) huge = 1.0/tiny if (job .eq. 1) cmach = eps if (job .eq. 2) cmach = tiny if (job .eq. 3) cmach = huge return end arpack-akloeckner-07/LAPACK/crot.f0000644000175000017500000000465706153460160016561 0ustar andreasandreas SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, INCY, N REAL C COMPLEX S * .. * .. Array Arguments .. COMPLEX CX( * ), CY( * ) * .. * * Purpose * ======= * * CROT applies a plane rotation, where the cos (C) is real and the * sin (S) is complex, and the vectors CX and CY are complex. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vectors CX and CY. * * CX (input/output) COMPLEX array, dimension (N) * On input, the vector X. * On output, CX is overwritten with C*X + S*Y. * * INCX (input) INTEGER * The increment between successive values of CY. INCX <> 0. * * CY (input/output) COMPLEX array, dimension (N) * On input, the vector Y. * On output, CY is overwritten with -CONJG(S)*X + C*Y. * * INCY (input) INTEGER * The increment between successive values of CY. INCX <> 0. * * C (input) REAL * S (input) COMPLEX * C and S define a rotation * [ C S ] * [ -conjg(S) C ] * where C*C + S*CONJG(S) = 1.0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IX, IY COMPLEX STEMP * .. * .. Intrinsic Functions .. INTRINSIC CONJG * .. * .. Executable Statements .. * IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 .AND. INCY.EQ.1 ) $ GO TO 20 * * Code for unequal increments or equal increments not equal to 1 * IX = 1 IY = 1 IF( INCX.LT.0 ) $ IX = ( -N+1 )*INCX + 1 IF( INCY.LT.0 ) $ IY = ( -N+1 )*INCY + 1 DO 10 I = 1, N STEMP = C*CX( IX ) + S*CY( IY ) CY( IY ) = C*CY( IY ) - CONJG( S )*CX( IX ) CX( IX ) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * * Code for both increments equal to 1 * 20 CONTINUE DO 30 I = 1, N STEMP = C*CX( I ) + S*CY( I ) CY( I ) = C*CY( I ) - CONJG( S )*CX( I ) CX( I ) = STEMP 30 CONTINUE RETURN END arpack-akloeckner-07/LAPACK/ctrevc.f0000644000175000017500000003034406153460160017070 0ustar andreasandreas SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) REAL RWORK( * ) COMPLEX T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * Purpose * ======= * * CTREVC computes some or all of the right and/or left eigenvectors of * a complex upper triangular matrix T. * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: * * T*x = w*x, y'*T = w*y' * * where y' denotes the conjugate transpose of the vector y. * * If all eigenvectors are requested, the routine may either return the * matrices X and/or Y of right or left eigenvectors of T, or the * products Q*X and/or Q*Y, where Q is an input unitary * matrix. If T was obtained from the Schur factorization of an * original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of * right or left eigenvectors of A. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'R': compute right eigenvectors only; * = 'L': compute left eigenvectors only; * = 'B': compute both right and left eigenvectors. * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, * and backtransform them using the input matrices * supplied in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. * If HOWMNY = 'A' or 'B', SELECT is not referenced. * To select the eigenvector corresponding to the j-th * eigenvalue, SELECT(j) must be set to .TRUE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) COMPLEX array, dimension (LDT,N) * The upper triangular matrix T. T is modified, but restored * on exit. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * VL (input/output) COMPLEX array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the unitary matrix Q of * Schur vectors returned by CHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= max(1,N) if * SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) COMPLEX array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must * contain an N-by-N matrix Q (usually the unitary matrix Q of * Schur vectors returned by CHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= max(1,N) if * SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) INTEGER * The number of columns in the arrays VL and/or VR actually * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M * is set to N. Each selected eigenvector occupies one * column. * * WORK (workspace) COMPLEX array, dimension (2*N) * * RWORK (workspace) REAL array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The algorithm used in this program is basically backward (forward) * substitution, with scaling to make the the code robust against * possible overflow. * * Each eigenvector is normalized so that the element of largest * magnitude has magnitude 1; here the magnitude of a complex number * (x,y) is taken to be |x| + |y|. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) COMPLEX CMZERO, CMONE PARAMETER ( CMZERO = ( 0.0E+0, 0.0E+0 ), $ CMONE = ( 1.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV INTEGER I, II, IS, J, K, KI REAL OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL COMPLEX CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER ICAMAX REAL SCASUM, SLAMCH EXTERNAL LSAME, ICAMAX, SCASUM, SLAMCH * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEMV, CLATRS, CSSCAL, SLABAD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, REAL * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'O' ) SOMEV = LSAME( HOWMNY, 'S' ) * * Set M to the number of columns required to store the selected * eigenvectors. * IF( SOMEV ) THEN M = 0 DO 10 J = 1, N IF( SELECT( J ) ) $ M = M + 1 10 CONTINUE ELSE M = N END IF * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE IF( MM.LT.M ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set the constants to control overflow. * UNFL = SLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL SLABAD( UNFL, OVFL ) ULP = SLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) * * Store the diagonal elements of T in working array WORK. * DO 20 I = 1, N WORK( I+N ) = T( I, I ) 20 CONTINUE * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * RWORK( 1 ) = ZERO DO 30 J = 2, N RWORK( J ) = SCASUM( J-1, T( 1, J ), 1 ) 30 CONTINUE * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IS = M DO 80 KI = N, 1, -1 * IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 80 END IF SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) * WORK( 1 ) = CMONE * * Form right-hand side. * DO 40 K = 1, KI - 1 WORK( K ) = -T( K, KI ) 40 CONTINUE * * Solve the triangular system: * (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. * DO 50 K = 1, KI - 1 T( K, K ) = T( K, K ) - T( KI, KI ) IF( CABS1( T( K, K ) ).LT.SMIN ) $ T( K, K ) = SMIN 50 CONTINUE * IF( KI.GT.1 ) THEN CALL CLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', $ KI-1, T, LDT, WORK( 1 ), SCALE, RWORK, $ INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL CCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 ) * II = ICAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / CABS1( VR( II, IS ) ) CALL CSSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 60 K = KI + 1, N VR( K, IS ) = CMZERO 60 CONTINUE ELSE IF( KI.GT.1 ) $ CALL CGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ), $ 1, CMPLX( SCALE ), VR( 1, KI ), 1 ) * II = ICAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / CABS1( VR( II, KI ) ) CALL CSSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF * * Set back the original diagonal elements of T. * DO 70 K = 1, KI - 1 T( K, K ) = WORK( K+N ) 70 CONTINUE * IS = IS - 1 80 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IS = 1 DO 130 KI = 1, N * IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 END IF SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) * WORK( N ) = CMONE * * Form right-hand side. * DO 90 K = KI + 1, N WORK( K ) = -CONJG( T( KI, K ) ) 90 CONTINUE * * Solve the triangular system: * (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. * DO 100 K = KI + 1, N T( K, K ) = T( K, K ) - T( KI, KI ) IF( CABS1( T( K, K ) ).LT.SMIN ) $ T( K, K ) = SMIN 100 CONTINUE * IF( KI.LT.N ) THEN CALL CLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, $ WORK( KI+1 ), SCALE, RWORK, INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL CCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 ) * II = ICAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / CABS1( VL( II, IS ) ) CALL CSSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 110 K = 1, KI - 1 VL( K, IS ) = CMZERO 110 CONTINUE ELSE IF( KI.LT.N ) $ CALL CGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1 ), 1, CMPLX( SCALE ), $ VL( 1, KI ), 1 ) * II = ICAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / CABS1( VL( II, KI ) ) CALL CSSCAL( N, REMAX, VL( 1, KI ), 1 ) END IF * * Set back the original diagonal elements of T. * DO 120 K = KI + 1, N T( K, K ) = WORK( K+N ) 120 CONTINUE * IS = IS + 1 130 CONTINUE END IF * RETURN * * End of CTREVC * END arpack-akloeckner-07/LAPACK/ctrexc.f0000644000175000017500000001075506153460160017076 0ustar andreasandreas SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. COMPLEX Q( LDQ, * ), T( LDT, * ) * .. * * Purpose * ======= * * CTREXC reorders the Schur factorization of a complex matrix * A = Q*T*Q**H, so that the diagonal element of T with row index IFST * is moved to row ILST. * * The Schur form T is reordered by a unitary similarity transformation * Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by * postmultplying it with Z. * * Arguments * ========= * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) COMPLEX array, dimension (LDT,N) * On entry, the upper triangular matrix T. * On exit, the reordered upper triangular matrix. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) COMPLEX array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * unitary transformation matrix Z which reorders T. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= max(1,N). * * IFST (input) INTEGER * ILST (input) INTEGER * Specify the reordering of the diagonal elements of T: * The element with row index IFST is moved to row ILST by a * sequence of transpositions between adjacent elements. * 1 <= IFST <= N; 1 <= ILST <= N. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL WANTQ INTEGER K, M1, M2, M3 REAL CS COMPLEX SN, T11, T22, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLARTG, CROT, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Decode and test the input parameters. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -7 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.1 .OR. IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Move the IFST-th diagonal element forward down the diagonal. * M1 = 0 M2 = -1 M3 = 1 ELSE * * Move the IFST-th diagonal element backward up the diagonal. * M1 = -1 M2 = 0 M3 = -1 END IF * DO 10 K = IFST + M1, ILST + M2, M3 * * Interchange the k-th and (k+1)-th diagonal elements. * T11 = T( K, K ) T22 = T( K+1, K+1 ) * * Determine the transformation to perform the interchange. * CALL CLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( K+2.LE.N ) $ CALL CROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, $ SN ) CALL CROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, CONJG( SN ) ) * T( K, K ) = T22 T( K+1, K+1 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL CROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, $ CONJG( SN ) ) END IF * 10 CONTINUE * RETURN * * End of CTREXC * END arpack-akloeckner-07/LAPACK/ctrsen.f0000644000175000017500000002516706153460161017110 0ustar andreasandreas SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER INFO, LDQ, LDT, LWORK, M, N REAL S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) COMPLEX Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) * .. * * Purpose * ======= * * CTRSEN reorders the Schur factorization of a complex matrix * A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in * the leading positions on the diagonal of the upper triangular matrix * T, and the leading columns of Q form an orthonormal basis of the * corresponding right invariant subspace. * * Optionally the routine computes the reciprocal condition numbers of * the cluster of eigenvalues and/or the invariant subspace. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies whether condition numbers are required for the * cluster of eigenvalues (S) or the invariant subspace (SEP): * = 'N': none; * = 'E': for eigenvalues only (S); * = 'V': for invariant subspace only (SEP); * = 'B': for both eigenvalues and invariant subspace (S and * SEP). * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * SELECT (input) LOGICAL array, dimension (N) * SELECT specifies the eigenvalues in the selected cluster. To * select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) COMPLEX array, dimension (LDT,N) * On entry, the upper triangular matrix T. * On exit, T is overwritten by the reordered matrix T, with the * selected eigenvalues as the leading diagonal elements. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) COMPLEX array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * unitary transformation matrix which reorders T; the leading M * columns of Q form an orthonormal basis for the specified * invariant subspace. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= 1; and if COMPQ = 'V', LDQ >= N. * * W (output) COMPLEX * The reordered eigenvalues of T, in the same order as they * appear on the diagonal of T. * * M (output) INTEGER * The dimension of the specified invariant subspace. * 0 <= M <= N. * * S (output) REAL * If JOB = 'E' or 'B', S is a lower bound on the reciprocal * condition number for the selected cluster of eigenvalues. * S cannot underestimate the true reciprocal condition number * by more than a factor of sqrt(N). If M = 0 or N, S = 1. * If JOB = 'N' or 'V', S is not referenced. * * SEP (output) REAL * If JOB = 'V' or 'B', SEP is the estimated reciprocal * condition number of the specified invariant subspace. If * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * * WORK (workspace) COMPLEX array, dimension (LWORK) * If JOB = 'N', WORK is not referenced. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= 1; * if JOB = 'E', LWORK = M*(N-M); * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * CTRSEN first collects the selected eigenvalues by computing a unitary * transformation Z to move them to the top left corner of T. In other * words, the selected eigenvalues are the eigenvalues of T11 in: * * Z'*T*Z = ( T11 T12 ) n1 * ( 0 T22 ) n2 * n1 n2 * * where N = n1+n2 and Z' means the conjugate transpose of Z. The first * n1 columns of Z span the specified invariant subspace of T. * * If T has been obtained from the Schur factorization of a matrix * A = Q*T*Q', then the reordered Schur factorization of A is given by * A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the * corresponding invariant subspace of A. * * The reciprocal condition number of the average of the eigenvalues of * T11 may be returned in S. S lies between 0 (very badly conditioned) * and 1 (very well conditioned). It is computed as follows. First we * compute R so that * * P = ( I R ) n1 * ( 0 0 ) n2 * n1 n2 * * is the projector on the invariant subspace associated with T11. * R is the solution of the Sylvester equation: * * T11*R - R*T22 = T12. * * Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote * the two-norm of M. Then S is computed as the lower bound * * (1 + F-norm(R)**2)**(-1/2) * * on the reciprocal of 2-norm(P), the true reciprocal condition number. * S cannot underestimate 1 / 2-norm(P) by more than a factor of * sqrt(N). * * An approximate error bound for the computed average of the * eigenvalues of T11 is * * EPS * norm(T) / S * * where EPS is the machine precision. * * The reciprocal condition number of the right invariant subspace * spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. * SEP is defined as the separation of T11 and T22: * * sep( T11, T22 ) = sigma-min( C ) * * where sigma-min(C) is the smallest singular value of the * n1*n2-by-n1*n2 matrix * * C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) * * I(m) is an m by m identity matrix, and kprod denotes the Kronecker * product. We estimate sigma-min(C) by the reciprocal of an estimate of * the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) * cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). * * When SEP is small, small changes in T can cause large changes in * the invariant subspace. An approximate bound on the maximum angular * error in the computed right invariant subspace is * * EPS * norm(T) / SEP * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL WANTBH, WANTQ, WANTS, WANTSP INTEGER IERR, K, KASE, KS, N1, N2, NN REAL EST, RNORM, SCALE * .. * .. Local Arrays .. REAL RWORK( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL CLANGE EXTERNAL LSAME, CLANGE * .. * .. External Subroutines .. EXTERNAL CLACON, CLACPY, CTREXC, CTRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters. * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * * Set M to the number of selected eigenvalues. * M = 0 DO 10 K = 1, N IF( SELECT( K ) ) $ M = M + 1 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE IF( LWORK.LT.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND. $ LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTRSEN', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = CLANGE( '1', N, N, T, LDT, RWORK ) GO TO 40 END IF * * Collect the selected eigenvalues at the top left corner of T. * KS = 0 DO 20 K = 1, N IF( SELECT( K ) ) THEN KS = KS + 1 * * Swap the K-th eigenvalue to position KS. * IF( K.NE.KS ) $ CALL CTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR ) END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve the Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL CLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL CTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = CLANGE( 'F', N1, N2, WORK, N1, RWORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL CLACON( NN, WORK( NN+1 ), WORK, EST, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL CTRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11'*R - R*T22' = scale*X. * CALL CTRSYL( 'C', 'C', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Copy reordered eigenvalues to W. * DO 50 K = 1, N W( K ) = T( K, K ) 50 CONTINUE RETURN * * End of CTRSEN * END arpack-akloeckner-07/LAPACK/ctrsyl.f0000644000175000017500000002660206153460161017125 0ustar andreasandreas SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N REAL SCALE * .. * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CTRSYL solves the complex Sylvester matrix equation: * * op(A)*X + X*op(B) = scale*C or * op(A)*X - X*op(B) = scale*C, * * where op(A) = A or A**H, and A and B are both upper triangular. A is * M-by-M and B is N-by-N; the right hand side C and the solution X are * M-by-N; and scale is an output scale factor, set <= 1 to avoid * overflow in X. * * Arguments * ========= * * TRANA (input) CHARACTER*1 * Specifies the option op(A): * = 'N': op(A) = A (No transpose) * = 'C': op(A) = A**H (Conjugate transpose) * * TRANB (input) CHARACTER*1 * Specifies the option op(B): * = 'N': op(B) = B (No transpose) * = 'C': op(B) = B**H (Conjugate transpose) * * ISGN (input) INTEGER * Specifies the sign in the equation: * = +1: solve op(A)*X + X*op(B) = scale*C * = -1: solve op(A)*X - X*op(B) = scale*C * * M (input) INTEGER * The order of the matrix A, and the number of rows in the * matrices X and C. M >= 0. * * N (input) INTEGER * The order of the matrix B, and the number of columns in the * matrices X and C. N >= 0. * * A (input) COMPLEX array, dimension (LDA,M) * The upper triangular matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (input) COMPLEX array, dimension (LDB,N) * The upper triangular matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * C (input/output) COMPLEX array, dimension (LDC,N) * On entry, the M-by-N right hand side matrix C. * On exit, C is overwritten by the solution matrix X. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M) * * SCALE (output) REAL * The scale factor, scale, set <= 1 to avoid overflow in X. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1: A and B have common or very close eigenvalues; perturbed * values were used to solve the equation (but the matrices * A and B are unchanged). * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER J, K, L REAL BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM COMPLEX A11, SUML, SUMR, VEC, X11 * .. * .. Local Arrays .. REAL DUM( 1 ) * .. * .. External Functions .. LOGICAL LSAME REAL CLANGE, SLAMCH COMPLEX CDOTC, CDOTU EXTERNAL LSAME, CLANGE, SLAMCH, CDOTC, CDOTU * .. * .. External Subroutines .. EXTERNAL CSSCAL, SLABAD, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, REAL * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. $ LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. $ LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CTRSYL', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*REAL( M*N ) / EPS BIGNUM = ONE / SMLNUM SMIN = MAX( SMLNUM, EPS*CLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*CLANGE( 'M', N, N, B, LDB, DUM ) ) SCALE = ONE SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * DO 30 L = 1, N DO 20 K = M, 1, -1 * SUML = CDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, $ C( MIN( K+1, M ), L ), 1 ) SUMR = CDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) VEC = C( K, L ) - ( SUML+SGN*SUMR ) * SCALOC = ONE A11 = A( K, K ) + SGN*B( L, L ) DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X11 = ( VEC*CMPLX( SCALOC ) ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL CSSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 20 CONTINUE 30 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A' *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 L-1 * R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * DO 60 L = 1, N DO 50 K = 1, M * SUML = CDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) SUMR = CDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) VEC = C( K, L ) - ( SUML+SGN*SUMR ) * SCALOC = ONE A11 = CONJG( A( K, K ) ) + SGN*B( L, L ) DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ( VEC*CMPLX( SCALOC ) ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL CSSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 50 CONTINUE 60 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A'*X + ISGN*X*B' = C. * * The (K,L)th block of X is determined starting from * upper-right corner column by column by * * A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) * * Where * K-1 * R(K,L) = SUM [A'(I,K)*X(I,L)] + * I=1 * N * ISGN*SUM [X(K,J)*B'(L,J)]. * J=L+1 * DO 90 L = N, 1, -1 DO 80 K = 1, M * SUML = CDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) SUMR = CDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, $ B( L, MIN( L+1, N ) ), LDB ) VEC = C( K, L ) - ( SUML+SGN*CONJG( SUMR ) ) * SCALOC = ONE A11 = CONJG( A( K, K )+SGN*B( L, L ) ) DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ( VEC*CMPLX( SCALOC ) ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 70 J = 1, N CALL CSSCAL( M, SCALOC, C( 1, J ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 80 CONTINUE 90 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B' = C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] * I=K+1 J=L+1 * DO 120 L = N, 1, -1 DO 110 K = M, 1, -1 * SUML = CDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, $ C( MIN( K+1, M ), L ), 1 ) SUMR = CDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, $ B( L, MIN( L+1, N ) ), LDB ) VEC = C( K, L ) - ( SUML+SGN*CONJG( SUMR ) ) * SCALOC = ONE A11 = A( K, K ) + SGN*CONJG( B( L, L ) ) DA11 = ABS( REAL( A11 ) ) + ABS( AIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( REAL( VEC ) ) + ABS( AIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ( VEC*CMPLX( SCALOC ) ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL CSSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 110 CONTINUE 120 CONTINUE * END IF * RETURN * * End of CTRSYL * END arpack-akloeckner-07/LAPACK/cunm2r.f0000644000175000017500000001245306153460161017012 0ustar andreasandreas SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * CUNM2R overwrites the general complex m-by-n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'C', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'C', * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'C': apply Q' (Conjugate transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * CGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) COMPLEX array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by CGEQRF. * * C (input/output) COMPLEX array, dimension (LDC,N) * On entry, the m-by-n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * 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 LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL CLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'CUNM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)' * IF( NOTRAN ) THEN TAUI = TAU( I ) ELSE TAUI = CONJG( TAU( I ) ) END IF AII = A( I, I ) A( I, I ) = ONE CALL CLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, $ WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of CUNM2R * END arpack-akloeckner-07/LAPACK/dgbtf2.f0000644000175000017500000001412606153460161016753 0ustar andreasandreas SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ) * .. * * Purpose * ======= * * DGBTF2 computes an LU factorization of a real m-by-n band matrix A * using partial pivoting with row interchanges. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U, because of fill-in resulting from the row * interchanges. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J, JP, JU, KM, KV * .. * .. External Functions .. INTEGER IDAMAX EXTERNAL IDAMAX * .. * .. External Subroutines .. EXTERNAL DGER, DSCAL, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in. * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero. * DO 20 J = KU + 2, MIN( KV, N ) DO 10 I = KV - J + 2, KL AB( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * JU is the index of the last column affected by the current stage * of the factorization. * JU = 1 * DO 40 J = 1, MIN( M, N ) * * Set fill-in elements in column J+KV to zero. * IF( J+KV.LE.N ) THEN DO 30 I = 1, KL AB( I, J+KV ) = ZERO 30 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-J ) JP = IDAMAX( KM+1, AB( KV+1, J ), 1 ) IPIV( J ) = JP + J - 1 IF( AB( KV+JP, J ).NE.ZERO ) THEN JU = MAX( JU, MIN( J+KU+JP-1, N ) ) * * Apply interchange to columns J to JU. * IF( JP.NE.1 ) $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, $ AB( KV+1, J ), LDAB-1 ) * IF( KM.GT.0 ) THEN * * Compute multipliers. * CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) * * Update trailing submatrix within the band. * IF( JU.GT.J ) $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), $ LDAB-1 ) END IF ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = J END IF 40 CONTINUE RETURN * * End of DGBTF2 * END arpack-akloeckner-07/LAPACK/dgbtrf.f0000644000175000017500000003430606153460161017055 0ustar andreasandreas SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ) * .. * * Purpose * ======= * * DGBTRF computes an LU factorization of a real m-by-n band matrix A * using partial pivoting with row interchanges. * * This is the blocked version of the algorithm, calling Level 3 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U because of fill-in resulting from the row interchanges. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) INTEGER NBMAX, LDWORK PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) * .. * .. Local Scalars .. INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, $ JU, K2, KM, KV, NB, NW DOUBLE PRECISION TEMP * .. * .. Local Arrays .. DOUBLE PRECISION WORK13( LDWORK, NBMAX ), $ WORK31( LDWORK, NBMAX ) * .. * .. External Functions .. INTEGER IDAMAX, ILAENV EXTERNAL IDAMAX, ILAENV * .. * .. External Subroutines .. EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL, $ DSWAP, DTRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBTRF', -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 = ILAENV( 1, 'DGBTRF', ' ', M, N, KL, KU ) * * The block size must not exceed the limit set by the size of the * local arrays WORK13 and WORK31. * NB = MIN( NB, NBMAX ) * IF( NB.LE.1 .OR. NB.GT.KL ) THEN * * Use unblocked code * CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) ELSE * * Use blocked code * * Zero the superdiagonal elements of the work array WORK13 * DO 20 J = 1, NB DO 10 I = 1, J - 1 WORK13( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * Zero the subdiagonal elements of the work array WORK31 * DO 40 J = 1, NB DO 30 I = J + 1, NB WORK31( I, J ) = ZERO 30 CONTINUE 40 CONTINUE * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero * DO 60 J = KU + 2, MIN( KV, N ) DO 50 I = KV - J + 2, KL AB( I, J ) = ZERO 50 CONTINUE 60 CONTINUE * * JU is the index of the last column affected by the current * stage of the factorization * JU = 1 * DO 180 J = 1, MIN( M, N ), NB JB = MIN( NB, MIN( M, N )-J+1 ) * * The active part of the matrix is partitioned * * A11 A12 A13 * A21 A22 A23 * A31 A32 A33 * * Here A11, A21 and A31 denote the current block of JB columns * which is about to be factorized. The number of rows in the * partitioning are JB, I2, I3 respectively, and the numbers * of columns are JB, J2, J3. The superdiagonal elements of A13 * and the subdiagonal elements of A31 lie outside the band. * I2 = MIN( KL-JB, M-J-JB+1 ) I3 = MIN( JB, M-J-KL+1 ) * * J2 and J3 are computed after JU has been updated. * * Factorize the current block of JB columns * DO 80 JJ = J, J + JB - 1 * * Set fill-in elements in column JJ+KV to zero * IF( JJ+KV.LE.N ) THEN DO 70 I = 1, KL AB( I, JJ+KV ) = ZERO 70 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-JJ ) JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 ) IPIV( JJ ) = JP + JJ - J IF( AB( KV+JP, JJ ).NE.ZERO ) THEN JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) IF( JP.NE.1 ) THEN * * Apply interchange to columns J to J+JB-1 * IF( JP+JJ-1.LT.J+KL ) THEN * CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange affects columns J to JJ-1 of A31 * which are stored in the work array WORK31 * CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, $ AB( KV+JP, JJ ), LDAB-1 ) END IF END IF * * Compute multipliers * CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), $ 1 ) * * Update trailing submatrix within the band and within * the current block. JM is the index of the last column * which needs to be updated. * JM = MIN( JU, J+JB-1 ) IF( JM.GT.JJ ) $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, $ AB( KV, JJ+1 ), LDAB-1, $ AB( KV+1, JJ+1 ), LDAB-1 ) ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = JJ END IF * * Copy current column of A31 into the work array WORK31 * NW = MIN( JJ-J+1, I3 ) IF( NW.GT.0 ) $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, $ WORK31( 1, JJ-J+1 ), 1 ) 80 CONTINUE IF( J+JB.LE.N ) THEN * * Apply the row interchanges to the other blocks. * J2 = MIN( JU-J+1, KV ) - JB J3 = MAX( 0, JU-J-KV+1 ) * * Use DLASWP to apply the row interchanges to A12, A22, and * A32. * CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, $ IPIV( J ), 1 ) * * Adjust the pivot indices. * DO 90 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 90 CONTINUE * * Apply the row interchanges to A13, A23, and A33 * columnwise. * K2 = J - 1 + JB + J2 DO 110 I = 1, J3 JJ = K2 + I DO 100 II = J + I - 1, J + JB - 1 IP = IPIV( II ) IF( IP.NE.II ) THEN TEMP = AB( KV+1+II-JJ, JJ ) AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) AB( KV+1+IP-JJ, JJ ) = TEMP END IF 100 CONTINUE 110 CONTINUE * * Update the relevant part of the trailing submatrix * IF( J2.GT.0 ) THEN * * Update A12 * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1 ) * IF( I2.GT.0 ) THEN * * Update A22 * CALL DGEMM( 'No transpose', 'No transpose', I2, J2, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+1, J+JB ), LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A32 * CALL DGEMM( 'No transpose', 'No transpose', I3, J2, $ JB, -ONE, WORK31, LDWORK, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) END IF END IF * IF( J3.GT.0 ) THEN * * Copy the lower triangle of A13 into the work array * WORK13 * DO 130 JJ = 1, J3 DO 120 II = JJ, JB WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) 120 CONTINUE 130 CONTINUE * * Update A13 in the work array * CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, $ WORK13, LDWORK ) * IF( I2.GT.0 ) THEN * * Update A23 * CALL DGEMM( 'No transpose', 'No transpose', I2, J3, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), $ LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A33 * CALL DGEMM( 'No transpose', 'No transpose', I3, J3, $ JB, -ONE, WORK31, LDWORK, WORK13, $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) END IF * * Copy the lower triangle of A13 back into place * DO 150 JJ = 1, J3 DO 140 II = JJ, JB AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) 140 CONTINUE 150 CONTINUE END IF ELSE * * Adjust the pivot indices. * DO 160 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 160 CONTINUE END IF * * Partially undo the interchanges in the current block to * restore the upper triangular form of A31 and copy the upper * triangle of A31 back into place * DO 170 JJ = J + JB - 1, J, -1 JP = IPIV( JJ ) - JJ + 1 IF( JP.NE.1 ) THEN * * Apply interchange to columns J to JJ-1 * IF( JP+JJ-1.LT.J+KL ) THEN * * The interchange does not affect A31 * CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange does affect A31 * CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) END IF END IF * * Copy the current column of A31 back into place * NW = MIN( I3, JJ-J+1 ) IF( NW.GT.0 ) $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1, $ AB( KV+KL+1-JJ+J, JJ ), 1 ) 170 CONTINUE 180 CONTINUE END IF * RETURN * * End of DGBTRF * END arpack-akloeckner-07/LAPACK/dgbtrs.f0000644000175000017500000001265706153460161017077 0ustar andreasandreas SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 2.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, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) * .. * * Purpose * ======= * * DGBTRS solves a system of linear equations * A * X = B or A' * X = B * with a general band matrix A using the LU factorization computed * by DGBTRF. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * AB (input) DOUBLE PRECISION array, dimension (LDAB,N) * Details of the LU factorization of the band matrix A, as * computed by DGBTRF. U is stored as an upper triangular band * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and * the multipliers used during the factorization are stored in * rows KL+KU+2 to 2*KL+KU+1. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; 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 LNOTI, NOTRAN INTEGER I, J, KD, L, LM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. 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( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGBTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * KD = KU + KL + 1 LNOTI = KL.GT.0 * IF( NOTRAN ) THEN * * Solve A*X = B. * * Solve L*X = B, overwriting B with X. * * L is represented as a product of permutations and unit lower * triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), * where each transformation L(i) is a rank-one modification of * the identity matrix. * IF( LNOTI ) THEN DO 10 J = 1, N - 1 LM = MIN( KL, N-J ) L = IPIV( J ) IF( L.NE.J ) $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), $ LDB, B( J+1, 1 ), LDB ) 10 CONTINUE END IF * DO 20 I = 1, NRHS * * Solve U*X = B, overwriting B with X. * CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, $ AB, LDAB, B( 1, I ), 1 ) 20 CONTINUE * ELSE * * Solve A'*X = B. * DO 30 I = 1, NRHS * * Solve U'*X = B, overwriting B with X. * CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, $ LDAB, B( 1, I ), 1 ) 30 CONTINUE * * Solve L'*X = B, overwriting B with X. * IF( LNOTI ) THEN DO 40 J = N - 1, 1, -1 LM = MIN( KL, N-J ) CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) L = IPIV( J ) IF( L.NE.J ) $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 40 CONTINUE END IF END IF RETURN * * End of DGBTRS * END arpack-akloeckner-07/LAPACK/dgeqr2.f0000644000175000017500000000650206153460161016766 0ustar andreasandreas SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DGEQR2 computes a QR factorization of a real m by n matrix A: * A = Q * R. * * 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 A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the orthogonal matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER I, K DOUBLE PRECISION AII * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * 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( 'DGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of DGEQR2 * END arpack-akloeckner-07/LAPACK/dgttrf.f0000644000175000017500000001064406153460162017077 0ustar andreasandreas SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * * -- LAPACK routine (version 2.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, N * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * DGTTRF computes an LU factorization of a real tridiagonal matrix A * using elimination with partial pivoting and row interchanges. * * The factorization has the form * A = L * U * where L is a product of permutation and unit lower bidiagonal * matrices and U is upper triangular with nonzeros in only the main * diagonal and first two superdiagonals. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * DL (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, DL must contain the (n-1) subdiagonal elements of * A. * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, D must contain the diagonal elements of A. * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, DU must contain the (n-1) superdiagonal elements * of A. * On exit, DU is overwritten by the (n-1) elements of the first * superdiagonal of U. * * DU2 (output) DOUBLE PRECISION array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the * second superdiagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * 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. * * ===================================================================== * * .. Local Scalars .. INTEGER I DOUBLE PRECISION FACT, TEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DGTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Initialize IPIV(i) = i * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE * DO 20 I = 1, N - 1 IF( DL( I ).EQ.ZERO ) THEN * * Subdiagonal is zero, no elimination is required. * IF( D( I ).EQ.ZERO .AND. INFO.EQ.0 ) $ INFO = I IF( I.LT.N-1 ) $ DU2( I ) = ZERO ELSE IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * FACT = DL( I ) / D( I ) DL( I ) = FACT D( I+1 ) = D( I+1 ) - FACT*DU( I ) IF( I.LT.N-1 ) $ DU2( I ) = ZERO ELSE * * Interchange rows I and I+1, eliminate DL(I) * FACT = D( I ) / DL( I ) D( I ) = DL( I ) DL( I ) = FACT TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) IF( I.LT.N-1 ) THEN DU2( I ) = DU( I+1 ) DU( I+1 ) = -FACT*DU( I+1 ) END IF IPIV( I ) = IPIV( I ) + 1 END IF 20 CONTINUE IF( D( N ).EQ.ZERO .AND. INFO.EQ.0 ) THEN INFO = N RETURN END IF * RETURN * * End of DGTTRF * END arpack-akloeckner-07/LAPACK/dgttrs.f0000644000175000017500000001226306153460162017113 0ustar andreasandreas SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 2.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, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * DGTTRS solves one of the systems of equations * A*X = B or A'*X = B, * with a tridiagonal matrix A using the LU factorization computed * by DGTTRF. * * Arguments * ========= * * TRANS (input) CHARACTER * 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. * * DL (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) multipliers that define the matrix L from the * LU factorization of A. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the upper triangular matrix U from * the LU factorization of A. * * DU (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) elements of the first superdiagonal of U. * * DU2 (input) DOUBLE PRECISION array, dimension (N-2) * The (n-2) elements of the second superdiagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, B is overwritten by 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 * * ===================================================================== * * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, J DOUBLE PRECISION TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * 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( LDB.LT.MAX( N, 1 ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A*X = B using the LU factorization of A, * overwriting each right hand side vector with its solution. * DO 30 J = 1, NRHS * * Solve L*x = b. * DO 10 I = 1, N - 1 IF( IPIV( I ).EQ.I ) THEN B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) ELSE TEMP = B( I, J ) B( I, J ) = B( I+1, J ) B( I+1, J ) = TEMP - DL( I )*B( I, J ) END IF 10 CONTINUE * * Solve U*x = b. * B( N, J ) = B( N, J ) / D( N ) IF( N.GT.1 ) $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / $ D( N-1 ) DO 20 I = N - 2, 1, -1 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* $ B( I+2, J ) ) / D( I ) 20 CONTINUE 30 CONTINUE ELSE * * Solve A' * X = B. * DO 60 J = 1, NRHS * * Solve U'*x = b. * B( 1, J ) = B( 1, J ) / D( 1 ) IF( N.GT.1 ) $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) DO 40 I = 3, N B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* $ B( I-2, J ) ) / D( I ) 40 CONTINUE * * Solve L'*x = b. * DO 50 I = N - 1, 1, -1 IF( IPIV( I ).EQ.I ) THEN B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) ELSE TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - DL( I )*TEMP B( I, J ) = TEMP END IF 50 CONTINUE 60 CONTINUE END IF * * End of DGTTRS * END arpack-akloeckner-07/LAPACK/dlabad.f0000644000175000017500000000352006153460162017007 0ustar andreasandreas SUBROUTINE DLABAD( SMALL, LARGE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION LARGE, SMALL * .. * * Purpose * ======= * * DLABAD takes as input the values computed by SLAMCH for underflow and * overflow, and returns the square root of each of these values if the * log of LARGE is sufficiently large. This subroutine is intended to * identify machines with a large exponent range, such as the Crays, and * redefine the underflow and overflow limits to be the square roots of * the values computed by DLAMCH. This subroutine is needed because * DLAMCH does not compensate for poor arithmetic in the upper half of * the exponent range, as is found on a Cray. * * Arguments * ========= * * SMALL (input/output) DOUBLE PRECISION * On entry, the underflow threshold as computed by DLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of SMALL, otherwise unchanged. * * LARGE (input/output) DOUBLE PRECISION * On entry, the overflow threshold as computed by DLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of LARGE, otherwise unchanged. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LOG10, SQRT * .. * .. Executable Statements .. * * If it looks like we're on a Cray, take the square root of * SMALL and LARGE to avoid overflow and underflow problems. * IF( LOG10( LARGE ).GT.2000.D0 ) THEN SMALL = SQRT( SMALL ) LARGE = SQRT( LARGE ) END IF * RETURN * * End of DLABAD * END arpack-akloeckner-07/LAPACK/dlacon.f0000644000175000017500000001221306153460162017037 0ustar andreasandreas SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. INTEGER ISGN( * ) DOUBLE PRECISION V( * ), X( * ) * .. * * Purpose * ======= * * DLACON estimates the 1-norm of a square, real matrix A. * Reverse communication is used for evaluating matrix-vector products. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix. N >= 1. * * V (workspace) DOUBLE PRECISION array, dimension (N) * On the final return, V = A*W, where EST = norm(V)/norm(W) * (W is not returned). * * X (input/output) DOUBLE PRECISION array, dimension (N) * On an intermediate return, X should be overwritten by * A * X, if KASE=1, * A' * X, if KASE=2, * and DLACON must be re-called with all the other parameters * unchanged. * * ISGN (workspace) INTEGER array, dimension (N) * * EST (output) DOUBLE PRECISION * An estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to DLACON, KASE should be 0. * On an intermediate return, KASE will be 1 or 2, indicating * whether X should be overwritten by A * X or A' * X. * On the final return from DLACON, KASE will again be 0. * * Further Details * ======= ======= * * Contributed by Nick Higham, University of Manchester. * Originally named SONEST, dated March 16, 1988. * * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of * a real or complex matrix, with applications to condition estimation", * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DASUM EXTERNAL IDAMAX, DASUM * .. * .. External Subroutines .. EXTERNAL DCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, NINT, SIGN * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / DBLE( N ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = DASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. * 40 CONTINUE J = IDAMAX( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( J ) = ONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL DCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. * 110 CONTINUE JLAST = J J = IDAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL DCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN * * End of DLACON * END arpack-akloeckner-07/LAPACK/dlacpy.f0000644000175000017500000000462606153460162017064 0ustar andreasandreas SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 2.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 LDA, LDB, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * DLACPY copies all or part of a two-dimensional matrix A to another * matrix B. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be copied to B. * = 'U': Upper triangular part * = 'L': Lower triangular part * Otherwise: All of the matrix A * * 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) DOUBLE PRECISION array, dimension (LDA,N) * The m by n matrix A. If UPLO = 'U', only the upper triangle * or trapezoid is accessed; if UPLO = 'L', only the lower * triangle or trapezoid is accessed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (output) DOUBLE PRECISION array, dimension (LDB,N) * On exit, B = A in the locations specified by UPLO. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF RETURN * * End of DLACPY * END arpack-akloeckner-07/LAPACK/dladiv.f0000644000175000017500000000302506153460162017043 0ustar andreasandreas SUBROUTINE DLADIV( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, D, P, Q * .. * * Purpose * ======= * * DLADIV performs complex division in real arithmetic * * a + i*b * p + i*q = --------- * c + i*d * * The algorithm is due to Robert L. Smith and can be found * in D. Knuth, The art of Computer Programming, Vol.2, p.195 * * Arguments * ========= * * A (input) DOUBLE PRECISION * B (input) DOUBLE PRECISION * C (input) DOUBLE PRECISION * D (input) DOUBLE PRECISION * The scalars a, b, c, and d in the above expression. * * P (output) DOUBLE PRECISION * Q (output) DOUBLE PRECISION * The scalars p and q in the above expression. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION E, F * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( ABS( D ).LT.ABS( C ) ) THEN E = D / C F = C + D*E P = ( A+B*E ) / F Q = ( B-A*E ) / F ELSE E = C / D F = D + C*E P = ( B+A*E ) / F Q = ( -A+B*E ) / F END IF * RETURN * * End of DLADIV * END arpack-akloeckner-07/LAPACK/dlae2.f0000644000175000017500000000643006153460162016572 0ustar andreasandreas SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, RT1, RT2 * .. * * Purpose * ======= * * DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix * [ A B ] * [ B C ]. * On return, RT1 is the eigenvalue of larger absolute value, and RT2 * is the eigenvalue of smaller absolute value. * * Arguments * ========= * * A (input) DOUBLE PRECISION * The (1,1) element of the 2-by-2 matrix. * * B (input) DOUBLE PRECISION * The (1,2) and (2,1) elements of the 2-by-2 matrix. * * C (input) DOUBLE PRECISION * The (2,2) element of the 2-by-2 matrix. * * RT1 (output) DOUBLE PRECISION * The eigenvalue of larger absolute value. * * RT2 (output) DOUBLE PRECISION * The eigenvalue of smaller absolute value. * * Further Details * =============== * * RT1 is accurate to a few ulps barring over/underflow. * * RT2 may be inaccurate if there is massive cancellation in the * determinant A*C-B*B; higher precision or correctly rounded or * correctly truncated arithmetic would be needed to compute RT2 * accurately in all cases. * * Overflow is possible only if RT1 is within a factor of 5 of overflow. * Underflow is harmless if the input data is 0 or exceeds * underflow_threshold / macheps. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT END IF RETURN * * End of DLAE2 * END arpack-akloeckner-07/LAPACK/dlaev2.f0000644000175000017500000001075506153460162016765 0ustar andreasandreas SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 * .. * * Purpose * ======= * * DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix * [ A B ] * [ B C ]. * On return, RT1 is the eigenvalue of larger absolute value, RT2 is the * eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right * eigenvector for RT1, giving the decomposition * * [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] * [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. * * Arguments * ========= * * A (input) DOUBLE PRECISION * The (1,1) element of the 2-by-2 matrix. * * B (input) DOUBLE PRECISION * The (1,2) element and the conjugate of the (2,1) element of * the 2-by-2 matrix. * * C (input) DOUBLE PRECISION * The (2,2) element of the 2-by-2 matrix. * * RT1 (output) DOUBLE PRECISION * The eigenvalue of larger absolute value. * * RT2 (output) DOUBLE PRECISION * The eigenvalue of smaller absolute value. * * CS1 (output) DOUBLE PRECISION * SN1 (output) DOUBLE PRECISION * The vector (CS1, SN1) is a unit right eigenvector for RT1. * * Further Details * =============== * * RT1 is accurate to a few ulps barring over/underflow. * * RT2 may be inaccurate if there is massive cancellation in the * determinant A*C-B*B; higher precision or correctly rounded or * correctly truncated arithmetic would be needed to compute RT2 * accurately in all cases. * * CS1 and SN1 are accurate to a few ulps barring over/underflow. * * Overflow is possible only if RT1 is within a factor of 5 of overflow. * Underflow is harmless if the input data is 0 or exceeds * underflow_threshold / macheps. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION HALF PARAMETER ( HALF = 0.5D0 ) * .. * .. Local Scalars .. INTEGER SGN1, SGN2 DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, $ TB, TN * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) SGN1 = -1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) SGN1 = 1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT SGN1 = 1 END IF * * Compute the eigenvector * IF( DF.GE.ZERO ) THEN CS = DF + RT SGN2 = 1 ELSE CS = DF - RT SGN2 = -1 END IF ACS = ABS( CS ) IF( ACS.GT.AB ) THEN CT = -TB / CS SN1 = ONE / SQRT( ONE+CT*CT ) CS1 = CT*SN1 ELSE IF( AB.EQ.ZERO ) THEN CS1 = ONE SN1 = ZERO ELSE TN = -CS / TB CS1 = ONE / SQRT( ONE+TN*TN ) SN1 = TN*CS1 END IF END IF IF( SGN1.EQ.SGN2 ) THEN TN = CS1 CS1 = -SN1 SN1 = TN END IF RETURN * * End of DLAEV2 * END arpack-akloeckner-07/LAPACK/dlaexc.f0000644000175000017500000002505706153460162017051 0ustar andreasandreas SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. LOGICAL WANTQ INTEGER INFO, J1, LDQ, LDT, N, N1, N2 * .. * .. Array Arguments .. DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * Purpose * ======= * * DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in * an upper quasi-triangular matrix T by an orthogonal similarity * transformation. * * T must be in Schur canonical form, that is, block upper triangular * with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block * has its diagonal elemnts equal and its off-diagonal elements of * opposite sign. * * Arguments * ========= * * WANTQ (input) LOGICAL * = .TRUE. : accumulate the transformation in the matrix Q; * = .FALSE.: do not accumulate the transformation. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) DOUBLE PRECISION array, dimension (LDT,N) * On entry, the upper quasi-triangular matrix T, in Schur * canonical form. * On exit, the updated matrix T, again in Schur canonical form. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) * On entry, if WANTQ is .TRUE., the orthogonal matrix Q. * On exit, if WANTQ is .TRUE., the updated matrix Q. * If WANTQ is .FALSE., Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. * * J1 (input) INTEGER * The index of the first row of the first block T11. * * N1 (input) INTEGER * The order of the first block T11. N1 = 0, 1 or 2. * * N2 (input) INTEGER * The order of the second block T22. N2 = 0, 1 or 2. * * WORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * = 1: the transformed matrix T would be too far from Schur * form; the blocks are not swapped and T and Q are * unchanged. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TEN PARAMETER ( TEN = 1.0D+1 ) INTEGER LDD, LDX PARAMETER ( LDD = 4, LDX = 2 ) * .. * .. Local Scalars .. INTEGER IERR, J2, J3, J4, K, ND DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, $ WR1, WR2, XNORM * .. * .. Local Arrays .. DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), $ X( LDX, 2 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANGE EXTERNAL DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2, $ DROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN IF( J1+N1.GT.N ) $ RETURN * J2 = J1 + 1 J3 = J1 + 2 J4 = J1 + 3 * IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * T11 = T( J1, J1 ) T22 = T( J2, J2 ) * * Determine the transformation to perform the interchange. * CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( J3.LE.N ) $ CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, $ SN ) CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) * T( J1, J1 ) = T22 T( J2, J2 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * ELSE * * Swapping involves at least one 2-by-2 block. * * Copy the diagonal block of order N1+N2 to the local array D * and compute its norm. * ND = N1 + N2 CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD ) DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK ) * * Compute machine-dependent threshold for test for accepting * swap. * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) * * Solve T11*X - X*T22 = scale*T12 for X. * CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, $ LDX, XNORM, IERR ) * * Swap the adjacent diagonal blocks. * K = N1 + N1 + N2 - 3 GO TO ( 10, 20, 30 )K * 10 CONTINUE * * N1 = 1, N2 = 2: generate elementary reflector H so that: * * ( scale, X11, X12 ) H = ( 0, 0, * ) * U( 1 ) = SCALE U( 2 ) = X( 1, 1 ) U( 3 ) = X( 1, 2 ) CALL DLARFG( 3, U( 3 ), U, 1, TAU ) U( 3 ) = ONE T11 = T( J1, J1 ) * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, $ 3 )-T11 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK ) CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J3, J3 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 20 CONTINUE * * N1 = 2, N2 = 1: generate elementary reflector H so that: * * H ( -X11 ) = ( * ) * ( -X21 ) = ( 0 ) * ( scale ) = ( 0 ) * U( 1 ) = -X( 1, 1 ) U( 2 ) = -X( 2, 1 ) U( 3 ) = SCALE CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU ) U( 1 ) = ONE T33 = T( J3, J3 ) * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, $ 1 )-T33 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK ) CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK ) * T( J1, J1 ) = T33 T( J2, J1 ) = ZERO T( J3, J1 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 30 CONTINUE * * N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so * that: * * H(2) H(1) ( -X11 -X12 ) = ( * * ) * ( -X21 -X22 ) ( 0 * ) * ( scale 0 ) ( 0 0 ) * ( 0 scale ) ( 0 0 ) * U1( 1 ) = -X( 1, 1 ) U1( 2 ) = -X( 2, 1 ) U1( 3 ) = SCALE CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 ) U1( 1 ) = ONE * TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) ) U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 ) U2( 2 ) = -TEMP*U1( 3 ) U2( 3 ) = SCALE CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 ) U2( 1 ) = ONE * * Perform swap provisionally on diagonal block in D. * CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK ) CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK ) CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK ) CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK ) CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK ) CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK ) CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J4, J1 ) = ZERO T( J4, J2 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK ) CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK ) END IF * 40 CONTINUE * IF( N2.EQ.2 ) THEN * * Standardize new 2-by-2 block T11 * CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN ) CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, $ CS, SN ) CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) IF( WANTQ ) $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * IF( N1.EQ.2 ) THEN * * Standardize new 2-by-2 block T22 * J3 = J1 + N2 J4 = J3 + 1 CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN ) IF( J3+2.LE.N ) $ CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), $ LDT, CS, SN ) CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN ) IF( WANTQ ) $ CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN ) END IF * END IF RETURN * * Exit with INFO = 1 if swap was rejected. * 50 CONTINUE INFO = 1 RETURN * * End of DLAEXC * END arpack-akloeckner-07/LAPACK/dlagtm.f0000644000175000017500000001404406153460163017054 0ustar andreasandreas SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER LDB, LDX, N, NRHS DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), $ X( LDX, * ) * .. * * Purpose * ======= * * DLAGTM performs a matrix-vector product of the form * * B := alpha * A * X + beta * B * * where A is a tridiagonal matrix of order N, B and X are N by NRHS * matrices, and alpha and beta are real scalars, each of which may be * 0., 1., or -1. * * Arguments * ========= * * TRANS (input) CHARACTER * Specifies the operation applied to A. * = 'N': No transpose, B := alpha * A * X + beta * B * = 'T': Transpose, B := alpha * A'* X + beta * B * = 'C': 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 matrices X and B. * * ALPHA (input) DOUBLE PRECISION * The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, * it is assumed to be 0. * * DL (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) sub-diagonal elements of T. * * D (input) DOUBLE PRECISION array, dimension (N) * The diagonal elements of T. * * DU (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) super-diagonal elements of T. * * X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) * The N by NRHS matrix X. * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(N,1). * * BETA (input) DOUBLE PRECISION * The scalar beta. BETA must be 0., 1., or -1.; otherwise, * it is assumed to be 1. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the N by NRHS matrix B. * On exit, B is overwritten by the matrix expression * B := alpha * A * X + beta * B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(N,1). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( N.EQ.0 ) $ RETURN * * Multiply B by BETA if BETA.NE.1. * IF( BETA.EQ.ZERO ) THEN DO 20 J = 1, NRHS DO 10 I = 1, N B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE IF( BETA.EQ.-ONE ) THEN DO 40 J = 1, NRHS DO 30 I = 1, N B( I, J ) = -B( I, J ) 30 CONTINUE 40 CONTINUE END IF * IF( ALPHA.EQ.ONE ) THEN IF( LSAME( TRANS, 'N' ) ) THEN * * Compute B := B + A*X * DO 60 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + $ DU( 1 )*X( 2, J ) B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) + $ D( N )*X( N, J ) DO 50 I = 2, N - 1 B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) + $ D( I )*X( I, J ) + DU( I )*X( I+1, J ) 50 CONTINUE END IF 60 CONTINUE ELSE * * Compute B := B + A'*X * DO 80 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + $ DL( 1 )*X( 2, J ) B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) + $ D( N )*X( N, J ) DO 70 I = 2, N - 1 B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) + $ D( I )*X( I, J ) + DL( I )*X( I+1, J ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( ALPHA.EQ.-ONE ) THEN IF( LSAME( TRANS, 'N' ) ) THEN * * Compute B := B - A*X * DO 100 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - $ DU( 1 )*X( 2, J ) B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) - $ D( N )*X( N, J ) DO 90 I = 2, N - 1 B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) - $ D( I )*X( I, J ) - DU( I )*X( I+1, J ) 90 CONTINUE END IF 100 CONTINUE ELSE * * Compute B := B - A'*X * DO 120 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - $ DL( 1 )*X( 2, J ) B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) - $ D( N )*X( N, J ) DO 110 I = 2, N - 1 B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) - $ D( I )*X( I, J ) - DL( I )*X( I+1, J ) 110 CONTINUE END IF 120 CONTINUE END IF END IF RETURN * * End of DLAGTM * END arpack-akloeckner-07/LAPACK/dlahqr.f0000644000175000017500000003234606153460163017064 0ustar andreasandreas SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL WANTT, WANTZ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * DLAHQR is an auxiliary routine called by DHSEQR to update the * eigenvalues and Schur decomposition already computed by DHSEQR, by * dealing with the Hessenberg submatrix in rows and columns ILO to IHI. * * Arguments * ========= * * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * * N (input) INTEGER * The order of the matrix H. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper quasi-triangular in * rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless * ILO = 1). DLAHQR works primarily with the Hessenberg * submatrix in rows and columns ILO to IHI, but applies * transformations to all of H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * * H (input/output) DOUBLE PRECISION array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if WANTT is .TRUE., H is upper quasi-triangular in * rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in * standard form. If WANTT is .FALSE., the contents of H are * unspecified on exit. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * * WR (output) DOUBLE PRECISION array, dimension (N) * WI (output) DOUBLE PRECISION array, dimension (N) * The real and imaginary parts, respectively, of the computed * eigenvalues ILO to IHI are stored in the corresponding * elements of WR and WI. If two eigenvalues are computed as a * complex conjugate pair, they are stored in consecutive * elements of WR and WI, say the i-th and (i+1)th, with * WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the * eigenvalues are stored in the same order as on the diagonal * of the Schur form returned in H, with WR(i) = H(i,i), and, if * H(i:i+1,i:i+1) is a 2-by-2 diagonal block, * WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by DHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * > 0: DLAHQR failed to compute all the eigenvalues ILO to IHI * in a total of 30*(IHI-ILO+1) iterations; if INFO = i, * elements i+1:ihi of WR and WI contain those eigenvalues * which have been successfully computed. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION DAT1, DAT2 PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ DOUBLE PRECISION CS, H00, H10, H11, H12, H21, H22, H33, H33S, $ H43H34, H44, H44S, OVFL, S, SMLNUM, SN, SUM, $ T1, T2, T3, TST1, ULP, UNFL, V1, V2, V3 * .. * .. Local Arrays .. DOUBLE PRECISION V( 3 ), WORK( 1 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLANHS EXTERNAL DLAMCH, DLANHS * .. * .. External Subroutines .. EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * If norm(H) <= sqrt(OVFL), overflow should not occur. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( NH / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITN is the total number of QR iterations allowed. * ITN = 30*NH * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1 or 2. Each iteration of the loop works * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 10 CONTINUE L = ILO IF( I.LT.ILO ) $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * DO 130 ITS = 0, ITN * * Look for a single small subdiagonal element. * DO 20 K = I, L + 1, -1 TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) IF( TST1.EQ.ZERO ) $ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) $ GO TO 30 20 CONTINUE 30 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN * * Exceptional shift. * S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) H44 = DAT1*S H33 = H44 H43H34 = DAT2*S*S ELSE * * Prepare to use Wilkinson's double shift * H44 = H( I, I ) H33 = H( I-1, I-1 ) H43H34 = H( I, I-1 )*H( I-1, I ) END IF * * Look for two consecutive small subdiagonal elements. * DO 40 M = I - 2, L, -1 * * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. * H11 = H( M, M ) H22 = H( M+1, M+1 ) H21 = H( M+1, M ) H12 = H( M, M+1 ) H44S = H44 - H11 H33S = H33 - H11 V1 = ( H33S*H44S-H43H34 ) / H21 + H12 V2 = H22 - H11 - H33S - H44S V3 = H( M+2, M+1 ) S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) V1 = V1 / S V2 = V2 / S V3 = V3 / S V( 1 ) = V1 V( 2 ) = V2 V( 3 ) = V3 IF( M.EQ.L ) $ GO TO 50 H00 = H( M-1, M-1 ) H10 = H( M, M-1 ) TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) ) IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 ) $ GO TO 50 40 CONTINUE 50 CONTINUE * * Double-shift QR step * DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. NR is the order of G. * NR = MIN( 3, I-K+1 ) IF( K.GT.M ) $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 ) CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO IF( K.LT.I-1 ) $ H( K+2, K-1 ) = ZERO ELSE IF( M.GT.L ) THEN H( K, K-1 ) = -H( K, K-1 ) END IF V2 = V( 2 ) T2 = T1*V2 IF( NR.EQ.3 ) THEN V3 = V( 3 ) T3 = T1*V3 * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 60 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 60 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 70 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 70 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 80 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 80 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 90 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 90 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 100 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 100 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 110 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 110 CONTINUE END IF END IF 120 CONTINUE * 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 140 CONTINUE * IF( L.EQ.I ) THEN * * H(I,I-1) is negligible: one eigenvalue has converged. * WR( I ) = H( I, I ) WI( I ) = ZERO ELSE IF( L.EQ.I-1 ) THEN * * H(I-1,I-2) is negligible: a pair of eigenvalues have converged. * * Transform the 2-by-2 submatrix to standard Schur form, * and compute and store the eigenvalues. * CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), $ CS, SN ) * IF( WANTT ) THEN * * Apply the transformation to the rest of H. * IF( I2.GT.I ) $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, $ CS, SN ) CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) END IF IF( WANTZ ) THEN * * Apply the transformation to Z. * CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) END IF END IF * * Decrement number of remaining iterations, and return to start of * the main loop with new value of I. * ITN = ITN - ITS I = L - 1 GO TO 10 * 150 CONTINUE RETURN * * End of DLAHQR * END arpack-akloeckner-07/LAPACK/dlaln2.f0000644000175000017500000004040306153460163016756 0ustar andreasandreas SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL LTRANS INTEGER INFO, LDA, LDB, LDX, NA, NW DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * Purpose * ======= * * DLALN2 solves a system of the form (ca A - w D ) X = s B * or (ca A' - w D) X = s B with possible scaling ("s") and * perturbation of A. (A' means A-transpose.) * * A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA * real diagonal matrix, w is a real or complex value, and X and B are * NA x 1 matrices -- real if w is real, complex if w is complex. NA * may be 1 or 2. * * If w is complex, X and B are represented as NA x 2 matrices, * the first column of each being the real part and the second * being the imaginary part. * * "s" is a scaling factor (.LE. 1), computed by DLALN2, which is * so chosen that X can be computed without overflow. X is further * scaled if necessary to assure that norm(ca A - w D)*norm(X) is less * than overflow. * * If both singular values of (ca A - w D) are less than SMIN, * SMIN*identity will be used instead of (ca A - w D). If only one * singular value is less than SMIN, one element of (ca A - w D) will be * perturbed enough to make the smallest singular value roughly SMIN. * If both singular values are at least SMIN, (ca A - w D) will not be * perturbed. In any case, the perturbation will be at most some small * multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values * are computed by infinity-norm approximations, and thus will only be * correct to a factor of 2 or so. * * Note: all input quantities are assumed to be smaller than overflow * by a reasonable factor. (See BIGNUM.) * * Arguments * ========== * * LTRANS (input) LOGICAL * =.TRUE.: A-transpose will be used. * =.FALSE.: A will be used (not transposed.) * * NA (input) INTEGER * The size of the matrix A. It may (only) be 1 or 2. * * NW (input) INTEGER * 1 if "w" is real, 2 if "w" is complex. It may only be 1 * or 2. * * SMIN (input) DOUBLE PRECISION * The desired lower bound on the singular values of A. This * should be a safe distance away from underflow or overflow, * say, between (underflow/machine precision) and (machine * precision * overflow ). (See BIGNUM and ULP.) * * CA (input) DOUBLE PRECISION * The coefficient c, which A is multiplied by. * * A (input) DOUBLE PRECISION array, dimension (LDA,NA) * The NA x NA matrix A. * * LDA (input) INTEGER * The leading dimension of A. It must be at least NA. * * D1 (input) DOUBLE PRECISION * The 1,1 element in the diagonal matrix D. * * D2 (input) DOUBLE PRECISION * The 2,2 element in the diagonal matrix D. Not used if NW=1. * * B (input) DOUBLE PRECISION array, dimension (LDB,NW) * The NA x NW matrix B (right-hand side). If NW=2 ("w" is * complex), column 1 contains the real part of B and column 2 * contains the imaginary part. * * LDB (input) INTEGER * The leading dimension of B. It must be at least NA. * * WR (input) DOUBLE PRECISION * The real part of the scalar "w". * * WI (input) DOUBLE PRECISION * The imaginary part of the scalar "w". Not used if NW=1. * * X (output) DOUBLE PRECISION array, dimension (LDX,NW) * The NA x NW matrix X (unknowns), as computed by DLALN2. * If NW=2 ("w" is complex), on exit, column 1 will contain * the real part of X and column 2 will contain the imaginary * part. * * LDX (input) INTEGER * The leading dimension of X. It must be at least NA. * * SCALE (output) DOUBLE PRECISION * The scale factor that B must be multiplied by to insure * that overflow does not occur when computing X. Thus, * (ca A - w D) X will be SCALE*B, not B (ignoring * perturbations of A.) It will be at most 1. * * XNORM (output) DOUBLE PRECISION * The infinity-norm of X, when X is regarded as an NA x NW * real matrix. * * INFO (output) INTEGER * An error flag. It will be set to zero if no error occurs, * a negative number if an argument is in error, or a positive * number if ca A - w D had to be perturbed. * The possible values are: * = 0: No error occurred, and (ca A - w D) did not have to be * perturbed. * = 1: (ca A - w D) had to be perturbed to make its smallest * (or only) singular value greater than SMIN. * NOTE: In the interests of speed, this routine does not * check the inputs for errors. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. INTEGER ICMAX, J DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, $ UR22, XI1, XI2, XR1, XR2 * .. * .. Local Arrays .. LOGICAL RSWAP( 4 ), ZSWAP( 4 ) INTEGER IPIVOT( 4, 4 ) DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Equivalences .. EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), $ ( CR( 1, 1 ), CRV( 1 ) ) * .. * .. Data statements .. DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, $ 3, 2, 1 / * .. * .. Executable Statements .. * * Compute BIGNUM * SMLNUM = TWO*DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM SMINI = MAX( SMIN, SMLNUM ) * * Don't check for input errors * INFO = 0 * * Standard Initializations * SCALE = ONE * IF( NA.EQ.1 ) THEN * * 1 x 1 (i.e., scalar) system C X = B * IF( NW.EQ.1 ) THEN * * Real 1x1 system. * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CNORM = ABS( CSR ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR XNORM = ABS( X( 1, 1 ) ) ELSE * * Complex 1x1 system (w is complex) * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CSI = -WI*D1 CNORM = ABS( CSR ) + ABS( CSI ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CSI = ZERO CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, $ X( 1, 1 ), X( 1, 2 ) ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) END IF * ELSE * * 2x2 System * * Compute the real part of C = ca A - w D (or ca A' - w D ) * CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 IF( LTRANS ) THEN CR( 1, 2 ) = CA*A( 2, 1 ) CR( 2, 1 ) = CA*A( 1, 2 ) ELSE CR( 2, 1 ) = CA*A( 2, 1 ) CR( 1, 2 ) = CA*A( 1, 2 ) END IF * IF( NW.EQ.1 ) THEN * * Real 2x2 system (w is real) * * Find the largest element in C * CMAX = ZERO ICMAX = 0 * DO 10 J = 1, 4 IF( ABS( CRV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) ICMAX = J END IF 10 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) UR11R = ONE / UR11 LR21 = UR11R*CR21 UR22 = CR22 - UR12*LR21 * * If smaller pivot < SMINI, use SMINI * IF( ABS( UR22 ).LT.SMINI ) THEN UR22 = SMINI INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR1 = B( 2, 1 ) BR2 = B( 1, 1 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) END IF BR2 = BR2 - LR21*BR1 BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN IF( BBND.GE.BIGNUM*ABS( UR22 ) ) $ SCALE = ONE / BBND END IF * XR2 = ( BR2*SCALE ) / UR22 XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) IF( ZSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 END IF XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF ELSE * * Complex 2x2 system (w is complex) * * Find the largest element in C * CI( 1, 1 ) = -WI*D1 CI( 2, 1 ) = ZERO CI( 1, 2 ) = ZERO CI( 2, 2 ) = -WI*D2 CMAX = ZERO ICMAX = 0 * DO 20 J = 1, 4 IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) ICMAX = J END IF 20 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) X( 1, 2 ) = TEMP*B( 1, 2 ) X( 2, 2 ) = TEMP*B( 2, 2 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) UI11 = CIV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) CI21 = CIV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) UI12 = CIV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) CI22 = CIV( IPIVOT( 4, ICMAX ) ) IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN * * Code when off-diagonals of pivoted C are real * IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN TEMP = UI11 / UR11 UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) UI11R = -TEMP*UR11R ELSE TEMP = UR11 / UI11 UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) UR11R = -TEMP*UI11R END IF LR21 = CR21*UR11R LI21 = CR21*UI11R UR12S = UR12*UR11R UI12S = UR12*UI11R UR22 = CR22 - UR12*LR21 UI22 = CI22 - UR12*LI21 ELSE * * Code when diagonals of pivoted C are real * UR11R = ONE / UR11 UI11R = ZERO LR21 = CR21*UR11R LI21 = CI21*UR11R UR12S = UR12*UR11R UI12S = UI12*UR11R UR22 = CR22 - UR12*LR21 + UI12*LI21 UI22 = -UR12*LI21 - UI12*LR21 END IF U22ABS = ABS( UR22 ) + ABS( UI22 ) * * If smaller pivot < SMINI, use SMINI * IF( U22ABS.LT.SMINI ) THEN UR22 = SMINI UI22 = ZERO INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR2 = B( 1, 1 ) BR1 = B( 2, 1 ) BI2 = B( 1, 2 ) BI1 = B( 2, 2 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) BI1 = B( 1, 2 ) BI2 = B( 2, 2 ) END IF BR2 = BR2 - LR21*BR1 + LI21*BI1 BI2 = BI2 - LI21*BR1 - LR21*BI1 BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), $ ABS( BR2 )+ABS( BI2 ) ) IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN IF( BBND.GE.BIGNUM*U22ABS ) THEN SCALE = ONE / BBND BR1 = SCALE*BR1 BI1 = SCALE*BI1 BR2 = SCALE*BR2 BI2 = SCALE*BI2 END IF END IF * CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 ) XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2 XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2 IF( ZSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 X( 1, 2 ) = XI2 X( 2, 2 ) = XI1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 X( 1, 2 ) = XI1 X( 2, 2 ) = XI2 END IF XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) X( 1, 2 ) = TEMP*X( 1, 2 ) X( 2, 2 ) = TEMP*X( 2, 2 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF END IF END IF * RETURN * * End of DLALN2 * END arpack-akloeckner-07/LAPACK/dlamch.f0000644000175000017500000006050306153460163017035 0ustar andreasandreas DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER CMACH * .. * * Purpose * ======= * * DLAMCH determines double precision machine parameters. * * Arguments * ========= * * CMACH (input) CHARACTER*1 * Specifies the value to be returned by DLAMCH: * = 'E' or 'e', DLAMCH := eps * = 'S' or 's , DLAMCH := sfmin * = 'B' or 'b', DLAMCH := base * = 'P' or 'p', DLAMCH := eps*base * = 'N' or 'n', DLAMCH := t * = 'R' or 'r', DLAMCH := rnd * = 'M' or 'm', DLAMCH := emin * = 'U' or 'u', DLAMCH := rmin * = 'L' or 'l', DLAMCH := emax * = 'O' or 'o', DLAMCH := rmax * * where * * eps = relative machine precision * sfmin = safe minimum, such that 1/sfmin does not overflow * base = base of the machine * prec = eps*base * t = number of (base) digits in the mantissa * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise * emin = minimum exponent before (gradual) underflow * rmin = underflow threshold - base**(emin-1) * emax = largest exponent before overflow * rmax = overflow threshold - (base**emax)*(1-eps) * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL FIRST, LRND INTEGER BETA, IMAX, IMIN, IT DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, $ RND, SFMIN, SMALL, T * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLAMC2 * .. * .. Save statement .. SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, $ EMAX, RMAX, PREC * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) BASE = BETA T = IT IF( LRND ) THEN RND = ONE EPS = ( BASE**( 1-IT ) ) / 2 ELSE RND = ZERO EPS = BASE**( 1-IT ) END IF PREC = EPS*BASE EMIN = IMIN EMAX = IMAX SFMIN = RMIN SMALL = ONE / RMAX IF( SMALL.GE.SFMIN ) THEN * * Use SMALL plus a bit, to avoid the possibility of rounding * causing overflow when computing 1/sfmin. * SFMIN = SMALL*( ONE+EPS ) END IF END IF * IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = BASE ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = PREC ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = T ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = EMIN ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = RMIN ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = EMAX ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = RMAX END IF * DLAMCH = RMACH RETURN * * End of DLAMCH * END * ************************************************************************ * SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE1, RND INTEGER BETA, T * .. * * Purpose * ======= * * DLAMC1 determines the machine parameters given by BETA, T, RND, and * IEEE1. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * IEEE1 (output) LOGICAL * Specifies whether rounding appears to be done in the IEEE * 'round to nearest' style. * * Further Details * =============== * * The routine is based on the routine ENVRON by Malcolm and * incorporates suggestions by Gentleman and Marovich. See * * Malcolm M. A. (1972) Algorithms to reveal properties of * floating-point arithmetic. Comms. of the ACM, 15, 949-951. * * Gentleman W. M. and Marovich S. B. (1974) More on algorithms * that reveal properties of floating point arithmetic units. * Comms. of the ACM, 17, 276-277. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, LIEEE1, LRND INTEGER LBETA, LT DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Save statement .. SAVE FIRST, LIEEE1, LBETA, LRND, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ONE = 1 * * LBETA, LIEEE1, LT and LRND are the local values of BETA, * IEEE1, T and RND. * * Throughout this routine we use the function DLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * Compute a = 2.0**m with the smallest positive integer m such * that * * fl( a + 1.0 ) = a. * A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 10 CONTINUE IF( C.EQ.ONE ) THEN A = 2*A C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 10 END IF *+ END WHILE * * Now compute b = 2.0**m with the smallest positive integer m * such that * * fl( a + b ) .gt. a. * B = 1 C = DLAMC3( A, B ) * *+ WHILE( C.EQ.A )LOOP 20 CONTINUE IF( C.EQ.A ) THEN B = 2*B C = DLAMC3( A, B ) GO TO 20 END IF *+ END WHILE * * Now compute the base. a and c are neighbouring floating point * numbers in the interval ( beta**t, beta**( t + 1 ) ) and so * their difference is beta. Adding 0.25 to c is to ensure that it * is truncated to beta and not ( beta - 1 ). * QTR = ONE / 4 SAVEC = C C = DLAMC3( C, -A ) LBETA = C + QTR * * Now determine whether rounding or chopping occurs, by adding a * bit less than beta/2 and a bit more than beta/2 to a. * B = LBETA F = DLAMC3( B / 2, -B / 100 ) C = DLAMC3( F, A ) IF( C.EQ.A ) THEN LRND = .TRUE. ELSE LRND = .FALSE. END IF F = DLAMC3( B / 2, B / 100 ) C = DLAMC3( F, A ) IF( ( LRND ) .AND. ( C.EQ.A ) ) $ LRND = .FALSE. * * Try and decide whether rounding is done in the IEEE 'round to * nearest' style. B/2 is half a unit in the last place of the two * numbers A and SAVEC. Furthermore, A is even, i.e. has last bit * zero, and SAVEC is odd. Thus adding B/2 to A should not change * A, but adding B/2 to SAVEC should change SAVEC. * T1 = DLAMC3( B / 2, A ) T2 = DLAMC3( B / 2, SAVEC ) LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND * * Now find the mantissa, t. It should be the integer part of * log to the base beta of a, however it is safer to determine t * by powering. So we find t as the smallest positive integer for * which * * fl( beta**t + 1.0 ) = 1.0. * LT = 0 A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 30 CONTINUE IF( C.EQ.ONE ) THEN LT = LT + 1 A = A*LBETA C = DLAMC3( A, ONE ) C = DLAMC3( C, -A ) GO TO 30 END IF *+ END WHILE * END IF * BETA = LBETA T = LT RND = LRND IEEE1 = LIEEE1 RETURN * * End of DLAMC1 * END * ************************************************************************ * SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL RND INTEGER BETA, EMAX, EMIN, T DOUBLE PRECISION EPS, RMAX, RMIN * .. * * Purpose * ======= * * DLAMC2 determines the machine parameters specified in its argument * list. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * EPS (output) DOUBLE PRECISION * The smallest positive number such that * * fl( 1.0 - EPS ) .LT. 1.0, * * where fl denotes the computed value. * * EMIN (output) INTEGER * The minimum exponent before (gradual) underflow occurs. * * RMIN (output) DOUBLE PRECISION * The smallest normalized number for the machine, given by * BASE**( EMIN - 1 ), where BASE is the floating point value * of BETA. * * EMAX (output) INTEGER * The maximum exponent before overflow occurs. * * RMAX (output) DOUBLE PRECISION * The largest positive number for the machine, given by * BASE**EMAX * ( 1 - EPS ), where BASE is the floating point * value of BETA. * * Further Details * =============== * * The computation of EPS is based on a routine PARANOIA by * W. Kahan of the University of California at Berkeley. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, $ NGNMIN, NGPMIN DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, $ SIXTH, SMALL, THIRD, TWO, ZERO * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. External Subroutines .. EXTERNAL DLAMC1, DLAMC4, DLAMC5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Save statement .. SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, $ LRMIN, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / , IWARN / .FALSE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ZERO = 0 ONE = 1 TWO = 2 * * LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of * BETA, T, RND, EPS, EMIN and RMIN. * * Throughout this routine we use the function DLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. * CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) * * Start to find EPS. * B = LBETA A = B**( -LT ) LEPS = A * * Try some tricks to see whether or not this is the correct EPS. * B = TWO / 3 HALF = ONE / 2 SIXTH = DLAMC3( B, -HALF ) THIRD = DLAMC3( SIXTH, SIXTH ) B = DLAMC3( THIRD, -HALF ) B = DLAMC3( B, SIXTH ) B = ABS( B ) IF( B.LT.LEPS ) $ B = LEPS * LEPS = 1 * *+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP 10 CONTINUE IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN LEPS = B C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) C = DLAMC3( HALF, -C ) B = DLAMC3( HALF, C ) C = DLAMC3( HALF, -B ) B = DLAMC3( HALF, C ) GO TO 10 END IF *+ END WHILE * IF( A.LT.LEPS ) $ LEPS = A * * Computation of EPS complete. * * Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). * Keep dividing A by BETA until (gradual) underflow occurs. This * is detected when we cannot recover the previous A. * RBASE = ONE / LBETA SMALL = ONE DO 20 I = 1, 3 SMALL = DLAMC3( SMALL*RBASE, ZERO ) 20 CONTINUE A = DLAMC3( ONE, SMALL ) CALL DLAMC4( NGPMIN, ONE, LBETA ) CALL DLAMC4( NGNMIN, -ONE, LBETA ) CALL DLAMC4( GPMIN, A, LBETA ) CALL DLAMC4( GNMIN, -A, LBETA ) IEEE = .FALSE. * IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN IF( NGPMIN.EQ.GPMIN ) THEN LEMIN = NGPMIN * ( Non twos-complement machines, no gradual underflow; * e.g., VAX ) ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN LEMIN = NGPMIN - 1 + LT IEEE = .TRUE. * ( Non twos-complement machines, with gradual underflow; * e.g., IEEE standard followers ) ELSE LEMIN = MIN( NGPMIN, GPMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) * ( Twos-complement machines, no gradual underflow; * e.g., CYBER 205 ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. $ ( GPMIN.EQ.GNMIN ) ) THEN IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT * ( Twos-complement machines with gradual underflow; * no known machine ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF *** * Comment out this if block if EMIN is ok IF( IWARN ) THEN FIRST = .TRUE. WRITE( 6, FMT = 9999 )LEMIN END IF *** * * Assume IEEE arithmetic if we found denormalised numbers above, * or if arithmetic seems to round in the IEEE style, determined * in routine DLAMC1. A true IEEE machine should have both things * true; however, faulty machines may have one or the other. * IEEE = IEEE .OR. LIEEE1 * * Compute RMIN by successive division by BETA. We could compute * RMIN as BASE**( EMIN - 1 ), but some machines underflow during * this computation. * LRMIN = 1 DO 30 I = 1, 1 - LEMIN LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) 30 CONTINUE * * Finally, call DLAMC5 to compute EMAX and RMAX. * CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) END IF * BETA = LBETA T = LT RND = LRND EPS = LEPS EMIN = LEMIN RMIN = LRMIN EMAX = LEMAX RMAX = LRMAX * RETURN * 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', $ ' EMIN = ', I8, / $ ' If, after inspection, the value EMIN looks', $ ' acceptable please comment out ', $ / ' the IF block as marked within the code of routine', $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) * * End of DLAMC2 * END * ************************************************************************ * DOUBLE PRECISION FUNCTION DLAMC3( A, B ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION A, B * .. * * Purpose * ======= * * DLAMC3 is intended to force A and B to be stored prior to doing * the addition of A and B , for use in situations where optimizers * might hold one of these in a register. * * Arguments * ========= * * A, B (input) DOUBLE PRECISION * The values A and B. * * ===================================================================== * * .. Executable Statements .. * DLAMC3 = A + B * RETURN * * End of DLAMC3 * END * ************************************************************************ * SUBROUTINE DLAMC4( EMIN, START, BASE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER BASE, EMIN DOUBLE PRECISION START * .. * * Purpose * ======= * * DLAMC4 is a service routine for DLAMC2. * * Arguments * ========= * * EMIN (output) EMIN * The minimum exponent before (gradual) underflow, computed by * setting A = START and dividing by BASE until the previous A * can not be recovered. * * START (input) DOUBLE PRECISION * The starting point for determining EMIN. * * BASE (input) INTEGER * The base of the machine. * * ===================================================================== * * .. Local Scalars .. INTEGER I DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Executable Statements .. * A = START ONE = 1 RBASE = ONE / BASE ZERO = 0 EMIN = 1 B1 = DLAMC3( A*RBASE, ZERO ) C1 = A C2 = A D1 = A D2 = A *+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. * $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP 10 CONTINUE IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. $ ( D2.EQ.A ) ) THEN EMIN = EMIN - 1 A = B1 B1 = DLAMC3( A / BASE, ZERO ) C1 = DLAMC3( B1*BASE, ZERO ) D1 = ZERO DO 20 I = 1, BASE D1 = D1 + B1 20 CONTINUE B2 = DLAMC3( A*RBASE, ZERO ) C2 = DLAMC3( B2 / RBASE, ZERO ) D2 = ZERO DO 30 I = 1, BASE D2 = D2 + B2 30 CONTINUE GO TO 10 END IF *+ END WHILE * RETURN * * End of DLAMC4 * END * ************************************************************************ * SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER BETA, EMAX, EMIN, P DOUBLE PRECISION RMAX * .. * * Purpose * ======= * * DLAMC5 attempts to compute RMAX, the largest machine floating-point * number, without overflow. It assumes that EMAX + abs(EMIN) sum * approximately to a power of 2. It will fail on machines where this * assumption does not hold, for example, the Cyber 205 (EMIN = -28625, * EMAX = 28718). It will also fail if the value supplied for EMIN is * too large (i.e. too close to zero), probably with overflow. * * Arguments * ========= * * BETA (input) INTEGER * The base of floating-point arithmetic. * * P (input) INTEGER * The number of base BETA digits in the mantissa of a * floating-point value. * * EMIN (input) INTEGER * The minimum exponent before (gradual) underflow. * * IEEE (input) LOGICAL * A logical flag specifying whether or not the arithmetic * system is thought to comply with the IEEE standard. * * EMAX (output) INTEGER * The largest exponent before overflow * * RMAX (output) DOUBLE PRECISION * The largest machine floating-point number. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP DOUBLE PRECISION OLDY, RECBAS, Y, Z * .. * .. External Functions .. DOUBLE PRECISION DLAMC3 EXTERNAL DLAMC3 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * First compute LEXP and UEXP, two powers of 2 that bound * abs(EMIN). We then assume that EMAX + abs(EMIN) will sum * approximately to the bound that is closest to abs(EMIN). * (EMAX is the exponent of the required number RMAX). * LEXP = 1 EXBITS = 1 10 CONTINUE TRY = LEXP*2 IF( TRY.LE.( -EMIN ) ) THEN LEXP = TRY EXBITS = EXBITS + 1 GO TO 10 END IF IF( LEXP.EQ.-EMIN ) THEN UEXP = LEXP ELSE UEXP = TRY EXBITS = EXBITS + 1 END IF * * Now -LEXP is less than or equal to EMIN, and -UEXP is greater * than or equal to EMIN. EXBITS is the number of bits needed to * store the exponent. * IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN EXPSUM = 2*LEXP ELSE EXPSUM = 2*UEXP END IF * * EXPSUM is the exponent range, approximately equal to * EMAX - EMIN + 1 . * EMAX = EXPSUM + EMIN - 1 NBITS = 1 + EXBITS + P * * NBITS is the total number of bits needed to store a * floating-point number. * IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN * * Either there are an odd number of bits used to store a * floating-point number, which is unlikely, or some bits are * not used in the representation of numbers, which is possible, * (e.g. Cray machines) or the mantissa has an implicit bit, * (e.g. IEEE machines, Dec Vax machines), which is perhaps the * most likely. We have to assume the last alternative. * If this is true, then we need to reduce EMAX by one because * there must be some way of representing zero in an implicit-bit * system. On machines like Cray, we are reducing EMAX by one * unnecessarily. * EMAX = EMAX - 1 END IF * IF( IEEE ) THEN * * Assume we are on an IEEE machine which reserves one exponent * for infinity and NaN. * EMAX = EMAX - 1 END IF * * Now create RMAX, the largest machine number, which should * be equal to (1.0 - BETA**(-P)) * BETA**EMAX . * * First compute 1.0 - BETA**(-P), being careful that the * result is less than 1.0 . * RECBAS = ONE / BETA Z = BETA - ONE Y = ZERO DO 20 I = 1, P Z = Z*RECBAS IF( Y.LT.ONE ) $ OLDY = Y Y = DLAMC3( Y, Z ) 20 CONTINUE IF( Y.GE.ONE ) $ Y = OLDY * * Now multiply by BETA**EMAX to get RMAX. * DO 30 I = 1, EMAX Y = DLAMC3( Y*BETA, ZERO ) 30 CONTINUE * RMAX = Y RETURN * * End of DLAMC5 * END arpack-akloeckner-07/LAPACK/dlarf.f0000644000175000017500000000605606153460164016701 0ustar andreasandreas SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * DLARF applies a real elementary reflector H to a real m by n matrix * C, from either the left or the right. H is represented in the form * * H = I - tau * v * v' * * where tau is a real scalar and v is a real vector. * * If tau = 0, then H is taken to be the unit matrix. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) DOUBLE PRECISION array, dimension * (1 + (M-1)*abs(INCV)) if SIDE = 'L' * or (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of H. V is not used if * TAU = 0. * * INCV (input) INTEGER * The increment between elements of v. INCV <> 0. * * TAU (input) DOUBLE PRECISION * The value tau in the representation of H. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w := C' * v * CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, $ WORK, 1 ) * * C := C - v * w' * CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w := C * v * CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - w * v' * CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of DLARF * END arpack-akloeckner-07/LAPACK/dlange.f0000644000175000017500000000765606153460163017051 0ustar andreasandreas DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DLANGE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * real matrix A. * * Description * =========== * * DLANGE returns the value * * DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in DLANGE as described * above. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. When M = 0, * DLANGE is set to zero. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. When N = 0, * DLANGE is set to zero. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, M SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, M WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, M VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANGE = VALUE RETURN * * End of DLANGE * END arpack-akloeckner-07/LAPACK/dlanhs.f0000644000175000017500000000763606153460163017066 0ustar andreasandreas DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * DLANHS returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * Hessenberg matrix A. * * Description * =========== * * DLANHS returns the value * * DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in DLANHS as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, DLANHS is * set to zero. * * A (input) DOUBLE PRECISION array, dimension (LDA,N) * The n by n upper Hessenberg matrix A; the part of A below the * first sub-diagonal is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * DLANHS = VALUE RETURN * * End of DLANHS * END arpack-akloeckner-07/LAPACK/dlanst.f0000644000175000017500000000676106153460163017100 0ustar andreasandreas DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * Purpose * ======= * * DLANST returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * real symmetric tridiagonal matrix A. * * Description * =========== * * DLANST returns the value * * DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in DLANST as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, DLANST is * set to zero. * * D (input) DOUBLE PRECISION array, dimension (N) * The diagonal elements of A. * * E (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) sub-diagonal or super-diagonal elements of A. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION ANORM, SCALE, SUM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN ANORM = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 ANORM = MAX( ANORM, ABS( D( I ) ) ) ANORM = MAX( ANORM, ABS( E( I ) ) ) 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. $ LSAME( NORM, 'I' ) ) THEN * * Find norm1(A). * IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), $ ABS( E( N-1 ) )+ABS( D( N ) ) ) DO 20 I = 2, N - 1 ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ $ ABS( E( I-1 ) ) ) 20 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( N.GT.1 ) THEN CALL DLASSQ( N-1, E, 1, SCALE, SUM ) SUM = 2*SUM END IF CALL DLASSQ( N, D, 1, SCALE, SUM ) ANORM = SCALE*SQRT( SUM ) END IF * DLANST = ANORM RETURN * * End of DLANST * END arpack-akloeckner-07/LAPACK/dlanv2.f0000644000175000017500000001116306153460163016771 0ustar andreasandreas SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. * * Purpose * ======= * * DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric * matrix in standard form: * * [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] * [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] * * where either * 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or * 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex * conjugate eigenvalues. * * Arguments * ========= * * A (input/output) DOUBLE PRECISION * B (input/output) DOUBLE PRECISION * C (input/output) DOUBLE PRECISION * D (input/output) DOUBLE PRECISION * On entry, the elements of the input matrix. * On exit, they are overwritten by the elements of the * standardised Schur form. * * RT1R (output) DOUBLE PRECISION * RT1I (output) DOUBLE PRECISION * RT2R (output) DOUBLE PRECISION * RT2I (output) DOUBLE PRECISION * The real and imaginary parts of the eigenvalues. If the * eigenvalues are both real, abs(RT1R) >= abs(RT2R); if the * eigenvalues are a complex conjugate pair, RT1I > 0. * * CS (output) DOUBLE PRECISION * SN (output) DOUBLE PRECISION * Parameters of the rotation matrix. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION AA, BB, CC, CS1, DD, P, SAB, SAC, SIGMA, SN1, $ TAU, TEMP * .. * .. External Functions .. DOUBLE PRECISION DLAPY2 EXTERNAL DLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. Executable Statements .. * * Initialize CS and SN * CS = ONE SN = ZERO * IF( C.EQ.ZERO ) THEN GO TO 10 * ELSE IF( B.EQ.ZERO ) THEN * * Swap rows and columns * CS = ZERO SN = ONE TEMP = D D = A A = TEMP B = -C C = ZERO GO TO 10 ELSE IF( (A-D).EQ.ZERO .AND. SIGN( ONE, B ).NE. $ SIGN( ONE, C ) ) THEN GO TO 10 ELSE * * Make diagonal elements equal * TEMP = A - D P = HALF*TEMP SIGMA = B + C TAU = DLAPY2( SIGMA, TEMP ) CS1 = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) SN1 = -( P / ( TAU*CS1 ) )*SIGN( ONE, SIGMA ) * * Compute [ AA BB ] = [ A B ] [ CS1 -SN1 ] * [ CC DD ] [ C D ] [ SN1 CS1 ] * AA = A*CS1 + B*SN1 BB = -A*SN1 + B*CS1 CC = C*CS1 + D*SN1 DD = -C*SN1 + D*CS1 * * Compute [ A B ] = [ CS1 SN1 ] [ AA BB ] * [ C D ] [-SN1 CS1 ] [ CC DD ] * A = AA*CS1 + CC*SN1 B = BB*CS1 + DD*SN1 C = -AA*SN1 + CC*CS1 D = -BB*SN1 + DD*CS1 * * Accumulate transformation * TEMP = CS*CS1 - SN*SN1 SN = CS*SN1 + SN*CS1 CS = TEMP * TEMP = HALF*( A+D ) A = TEMP D = TEMP * IF( C.NE.ZERO ) THEN IF( B.NE.ZERO ) THEN IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN * * Real eigenvalues: reduce to upper triangular form * SAB = SQRT( ABS( B ) ) SAC = SQRT( ABS( C ) ) P = SIGN( SAB*SAC, C ) TAU = ONE / SQRT( ABS( B+C ) ) A = TEMP + P D = TEMP - P B = B - C C = ZERO CS1 = SAB*TAU SN1 = SAC*TAU TEMP = CS*CS1 - SN*SN1 SN = CS*SN1 + SN*CS1 CS = TEMP END IF ELSE B = -C C = ZERO TEMP = CS CS = -SN SN = TEMP END IF END IF END IF * 10 CONTINUE * * Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). * RT1R = A RT2R = D IF( C.EQ.ZERO ) THEN RT1I = ZERO RT2I = ZERO ELSE RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) RT2I = -RT1I END IF RETURN * * End of DLANV2 * END arpack-akloeckner-07/LAPACK/dlaptm.f0000644000175000017500000001001706153460164017062 0ustar andreasandreas SUBROUTINE DLAPTM( N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER LDB, LDX, N, NRHS DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), X( LDX, * ) * .. * * Purpose * ======= * * DLAPTM multiplies an N by NRHS matrix X by a symmetric tridiagonal * matrix A and stores the result in a matrix B. The operation has the * form * * B := alpha * A * X + beta * B * * where alpha may be either 1. or -1. and beta may be 0., 1., or -1. * * Arguments * ========= * * 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 matrices X and B. * * ALPHA (input) DOUBLE PRECISION * The scalar alpha. ALPHA must be 1. or -1.; otherwise, * it is assumed to be 0. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the tridiagonal matrix A. * * E (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) subdiagonal or superdiagonal elements of A. * * X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) * The N by NRHS matrix X. * * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(N,1). * * BETA (input) DOUBLE PRECISION * The scalar beta. BETA must be 0., 1., or -1.; otherwise, * it is assumed to be 1. * * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) * On entry, the N by NRHS matrix B. * On exit, B is overwritten by the matrix expression * B := alpha * A * X + beta * B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(N,1). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * IF( N.EQ.0 ) $ RETURN * * Multiply B by BETA if BETA.NE.1. * IF( BETA.EQ.ZERO ) THEN DO 20 J = 1, NRHS DO 10 I = 1, N B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE IF( BETA.EQ.-ONE ) THEN DO 40 J = 1, NRHS DO 30 I = 1, N B( I, J ) = -B( I, J ) 30 CONTINUE 40 CONTINUE END IF * IF( ALPHA.EQ.ONE ) THEN * * Compute B := B + A*X * DO 60 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + $ E( 1 )*X( 2, J ) B( N, J ) = B( N, J ) + E( N-1 )*X( N-1, J ) + $ D( N )*X( N, J ) DO 50 I = 2, N - 1 B( I, J ) = B( I, J ) + E( I-1 )*X( I-1, J ) + $ D( I )*X( I, J ) + E( I )*X( I+1, J ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( ALPHA.EQ.-ONE ) THEN * * Compute B := B - A*X * DO 80 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - $ E( 1 )*X( 2, J ) B( N, J ) = B( N, J ) - E( N-1 )*X( N-1, J ) - $ D( N )*X( N, J ) DO 70 I = 2, N - 1 B( I, J ) = B( I, J ) - E( I-1 )*X( I-1, J ) - $ D( I )*X( I, J ) - E( I )*X( I+1, J ) 70 CONTINUE END IF 80 CONTINUE END IF RETURN * * End of DLAPTM * END arpack-akloeckner-07/LAPACK/dlapy2.f0000644000175000017500000000242006153460164016773 0ustar andreasandreas DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y * .. * * Purpose * ======= * * DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary * overflow. * * Arguments * ========= * * X (input) DOUBLE PRECISION * Y (input) DOUBLE PRECISION * X and Y specify the values x and y. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, Z * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN DLAPY2 = W ELSE DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF RETURN * * End of DLAPY2 * END arpack-akloeckner-07/LAPACK/dlapy3.f0000644000175000017500000000246206153460164017002 0ustar andreasandreas DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. DOUBLE PRECISION X, Y, Z * .. * * Purpose * ======= * * DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause * unnecessary overflow. * * Arguments * ========= * * X (input) DOUBLE PRECISION * Y (input) DOUBLE PRECISION * Z (input) DOUBLE PRECISION * X, Y and Z specify the values x, y and z. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. * .. Local Scalars .. DOUBLE PRECISION W, XABS, YABS, ZABS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN DLAPY3 = ZERO ELSE DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) END IF RETURN * * End of DLAPY3 * END arpack-akloeckner-07/LAPACK/dlaran.f0000644000175000017500000000513306153460164017045 0ustar andreasandreas DOUBLE PRECISION FUNCTION DLARAN( ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * DLARAN returns a random real number from a uniform (0,1) * distribution. * * Arguments * ========= * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine uses a multiplicative congruential method with modulus * 2**48 and multiplier 33952834046453 (see G.S.Fishman, * 'Multiplicative congruential random number generators with modulus * 2**b: an exhaustive analysis for b = 32 and a partial analysis for * b = 48', Math. Comp. 189, pp 331-344, 1990). * * 48-bit integers are stored in 4 integer array elements with 12 bits * per element. Hence the routine is portable across machines with * integers of 32 bits or more. * * ===================================================================== * * .. Parameters .. INTEGER M1, M2, M3, M4 PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) INTEGER IPW2 DOUBLE PRECISION R PARAMETER ( IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER IT1, IT2, IT3, IT4 * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MOD * .. * .. Executable Statements .. * * multiply the seed by the multiplier modulo 2**48 * IT4 = ISEED( 4 )*M4 IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3 IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2 IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 + $ ISEED( 4 )*M1 IT1 = MOD( IT1, IPW2 ) * * return updated seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 * * convert 48-bit integer to a real number in the interval (0,1) * DLARAN = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* $ ( DBLE( IT4 ) ) ) ) ) RETURN * * End of DLARAN * END arpack-akloeckner-07/LAPACK/dlarfg.f0000644000175000017500000000703706153460164017050 0ustar andreasandreas SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION ALPHA, TAU * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * Purpose * ======= * * DLARFG generates a real elementary reflector H of order n, such * that * * H * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, and x is an (n-1)-element real * vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a real scalar and v is a real (n-1)-element * vector. * * If the elements of x are all zero, then tau = 0 and H is taken to be * the unit matrix. * * Otherwise 1 <= tau <= 2. * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) DOUBLE PRECISION * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) DOUBLE PRECISION array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX > 0. * * TAU (output) DOUBLE PRECISION * The value tau. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 EXTERNAL DLAMCH, DLAPY2, DNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. External Subroutines .. EXTERNAL DSCAL * .. * .. Executable Statements .. * IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF * XNORM = DNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * RSAFMN = ONE / SAFMIN KNT = 0 10 CONTINUE KNT = KNT + 1 CALL DSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DNRM2( N-1, X, INCX ) BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = ( BETA-ALPHA ) / BETA CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of DLARFG * END arpack-akloeckner-07/LAPACK/dlarfx.f0000644000175000017500000004250606153460164017071 0ustar andreasandreas SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER LDC, M, N DOUBLE PRECISION TAU * .. * .. Array Arguments .. DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * DLARFX applies a real elementary reflector H to a real m by n * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a real scalar and v is a real vector. * * If tau = 0, then H is taken to be the unit matrix * * This version uses inline code if H has order < 11. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L' * or (N) if SIDE = 'R' * The vector v in the representation of H. * * TAU (input) DOUBLE PRECISION * The value tau in the representation of H. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= (1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * WORK is not referenced if H has order < 11. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. INTEGER J DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DGEMV, DGER * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * * w := C'*v * CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK, $ 1 ) * * C := C - tau * v * w' * CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * * w := C * v * CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, $ WORK, 1 ) * * C := C - tau * w * v' * CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 CONTINUE RETURN * * End of DLARFX * END arpack-akloeckner-07/LAPACK/dlarnd.f0000644000175000017500000000437706153460164017061 0ustar andreasandreas DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST * .. * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * DLARND returns a random real number from a uniform or normal * distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: uniform (0,1) * = 2: uniform (-1,1) * = 3: normal (0,1) * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine calls the auxiliary routine DLARAN to generate a random * real number from a uniform (0,1) distribution. The Box-Muller method * is used to transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. DOUBLE PRECISION T1, T2 * .. * .. External Functions .. DOUBLE PRECISION DLARAN EXTERNAL DLARAN * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, SQRT * .. * .. Executable Statements .. * * Generate a real random number from a uniform (0,1) distribution * T1 = DLARAN( ISEED ) * IF( IDIST.EQ.1 ) THEN * * uniform (0,1) * DLARND = T1 ELSE IF( IDIST.EQ.2 ) THEN * * uniform (-1,1) * DLARND = TWO*T1 - ONE ELSE IF( IDIST.EQ.3 ) THEN * * normal (0,1) * T2 = DLARAN( ISEED ) DLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 ) END IF RETURN * * End of DLARND * END arpack-akloeckner-07/LAPACK/dlarnv.f0000644000175000017500000000625206153460164017075 0ustar andreasandreas SUBROUTINE DLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION X( * ) * .. * * Purpose * ======= * * DLARNV returns a vector of n random real numbers from a uniform or * normal distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: uniform (0,1) * = 2: uniform (-1,1) * = 3: normal (0,1) * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * N (input) INTEGER * The number of random numbers to be generated. * * X (output) DOUBLE PRECISION array, dimension (N) * The generated random numbers. * * Further Details * =============== * * This routine calls the auxiliary routine DLARUV to generate random * real numbers from a uniform (0,1) distribution, in batches of up to * 128 using vectorisable code. The Box-Muller method is used to * transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) INTEGER LV PARAMETER ( LV = 128 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IL2, IV * .. * .. Local Arrays .. DOUBLE PRECISION U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL DLARUV * .. * .. Executable Statements .. * DO 40 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) IF( IDIST.EQ.3 ) THEN IL2 = 2*IL ELSE IL2 = IL END IF * * Call DLARUV to generate IL2 numbers from a uniform (0,1) * distribution (IL2 <= LV) * CALL DLARUV( ISEED, IL2, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = U( I ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = TWO*U( I ) - ONE 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ COS( TWOPI*U( 2*I ) ) 30 CONTINUE END IF 40 CONTINUE RETURN * * End of DLARNV * END arpack-akloeckner-07/LAPACK/dlartg.f0000644000175000017500000000760106153460164017063 0ustar andreasandreas SUBROUTINE DLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. DOUBLE PRECISION CS, F, G, R, SN * .. * * Purpose * ======= * * DLARTG generate a plane rotation so that * * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. * [ -SN CS ] [ G ] [ 0 ] * * This is a slower, more accurate version of the BLAS1 routine DROTG, * with the following other differences: * F and G are unchanged on return. * If G=0, then CS=1 and SN=0. * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any * floating point operations (saves work in DBDSQR when * there are zeros on the diagonal). * * If F exceeds G in magnitude, CS will be positive. * * Arguments * ========= * * F (input) DOUBLE PRECISION * The first component of vector to be rotated. * * G (input) DOUBLE PRECISION * The second component of vector to be rotated. * * CS (output) DOUBLE PRECISION * The cosine of the rotation. * * SN (output) DOUBLE PRECISION * The sine of the rotation. * * R (output) DOUBLE PRECISION * The nonzero component of the rotated vector. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) DOUBLE PRECISION TWO PARAMETER ( TWO = 2.0D0 ) * .. * .. Local Scalars .. LOGICAL FIRST INTEGER COUNT, I DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. * .. External Functions .. DOUBLE PRECISION DLAMCH EXTERNAL DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. SAFMIN = DLAMCH( 'S' ) EPS = DLAMCH( 'E' ) SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( DLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = ONE R = G ELSE F1 = F G1 = G SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) THEN COUNT = 0 10 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMN2 G1 = G1*SAFMN2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) $ GO TO 10 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 20 I = 1, COUNT R = R*SAFMX2 20 CONTINUE ELSE IF( SCALE.LE.SAFMN2 ) THEN COUNT = 0 30 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMX2 G1 = G1*SAFMX2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.LE.SAFMN2 ) $ GO TO 30 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 40 I = 1, COUNT R = R*SAFMN2 40 CONTINUE ELSE R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R END IF IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN CS = -CS SN = -SN R = -R END IF END IF RETURN * * End of DLARTG * END arpack-akloeckner-07/LAPACK/dlaruv.f0000644000175000017500000003770706153460165017116 0ustar andreasandreas SUBROUTINE DLARUV( ISEED, N, X ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) DOUBLE PRECISION X( N ) * .. * * Purpose * ======= * * DLARUV returns a vector of n random real numbers from a uniform (0,1) * distribution (n <= 128). * * This is an auxiliary routine called by DLARNV and ZLARNV. * * Arguments * ========= * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * N (input) INTEGER * The number of random numbers to be generated. N <= 128. * * X (output) DOUBLE PRECISION array, dimension (N) * The generated random numbers. * * Further Details * =============== * * This routine uses a multiplicative congruential method with modulus * 2**48 and multiplier 33952834046453 (see G.S.Fishman, * 'Multiplicative congruential random number generators with modulus * 2**b: an exhaustive analysis for b = 32 and a partial analysis for * b = 48', Math. Comp. 189, pp 331-344, 1990). * * 48-bit integers are stored in 4 integer array elements with 12 bits * per element. Hence the routine is portable across machines with * integers of 32 bits or more. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D0 ) INTEGER LV, IPW2 DOUBLE PRECISION R PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J * .. * .. Local Arrays .. INTEGER MM( LV, 4 ) * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MIN, MOD * .. * .. Data statements .. DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, $ 2549 / DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, $ 1145 / DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, $ 2253 / DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, $ 305 / DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, $ 3301 / DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, $ 1065 / DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, $ 3133 / DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, $ 2913 / DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, $ 3285 / DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, $ 1241 / DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, $ 1197 / DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, $ 3729 / DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, $ 2501 / DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, $ 1673 / DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, $ 541 / DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, $ 2753 / DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, $ 949 / DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, $ 2361 / DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, $ 1165 / DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, $ 4081 / DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, $ 2725 / DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, $ 3305 / DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, $ 3069 / DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, $ 3617 / DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, $ 3733 / DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, $ 409 / DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, $ 2157 / DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, $ 1361 / DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, $ 3973 / DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, $ 1865 / DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, $ 2525 / DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, $ 1409 / DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, $ 3445 / DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, $ 3577 / DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, $ 77 / DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, $ 3761 / DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, $ 2149 / DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, $ 1449 / DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, $ 3005 / DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, $ 225 / DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, $ 85 / DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, $ 3673 / DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, $ 3117 / DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, $ 3089 / DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, $ 1349 / DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, $ 2057 / DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, $ 413 / DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, $ 65 / DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, $ 1845 / DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, $ 697 / DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, $ 3085 / DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, $ 3441 / DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, $ 1573 / DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, $ 3689 / DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, $ 2941 / DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, $ 929 / DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, $ 533 / DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, $ 2841 / DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, $ 4077 / DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, $ 721 / DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, $ 2821 / DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, $ 2249 / DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, $ 2397 / DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, $ 2817 / DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, $ 245 / DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, $ 1913 / DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, $ 1997 / DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, $ 3121 / DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, $ 997 / DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, $ 1833 / DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, $ 2877 / DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, $ 1633 / DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, $ 981 / DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, $ 2009 / DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, $ 941 / DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, $ 2449 / DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, $ 197 / DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, $ 2441 / DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, $ 285 / DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, $ 1473 / DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, $ 2741 / DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, $ 3129 / DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, $ 909 / DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, $ 2801 / DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, $ 421 / DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, $ 4073 / DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, $ 2813 / DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, $ 2337 / DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, $ 1429 / DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, $ 1177 / DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, $ 1901 / DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, $ 81 / DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, $ 1669 / DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, $ 2633 / DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, $ 2269 / DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, $ 129 / DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, $ 1141 / DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, $ 249 / DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, $ 3917 / DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, $ 2481 / DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, $ 3941 / DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, $ 2217 / DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, $ 2749 / DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, $ 3041 / DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, $ 1877 / DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, $ 345 / DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, $ 2861 / DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, $ 1809 / DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, $ 3141 / DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, $ 2825 / DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, $ 157 / DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, $ 2881 / DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, $ 3637 / DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, $ 1465 / DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, $ 2829 / DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, $ 2161 / DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, $ 3365 / DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, $ 361 / DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, $ 2685 / DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, $ 3745 / DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, $ 2325 / DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, $ 3609 / DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, $ 3821 / DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, $ 3537 / DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, $ 517 / DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, $ 3017 / DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, $ 2141 / DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, $ 1537 / * .. * .. Executable Statements .. * I1 = ISEED( 1 ) I2 = ISEED( 2 ) I3 = ISEED( 3 ) I4 = ISEED( 4 ) * DO 10 I = 1, MIN( N, LV ) * * Multiply the seed by i-th power of the multiplier modulo 2**48 * IT4 = I4*MM( I, 4 ) IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + $ I4*MM( I, 1 ) IT1 = MOD( IT1, IPW2 ) * * Convert 48-bit integer to a real number in the interval (0,1) * X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* $ DBLE( IT4 ) ) ) ) 10 CONTINUE * * Return final value of seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 RETURN * * End of DLARUV * END arpack-akloeckner-07/LAPACK/dlascl.f0000644000175000017500000001623006153460165017047 0ustar andreasandreas SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DLASCL multiplies the M by N real matrix A by the real scalar * CTO/CFROM. This is done without over/underflow as long as the final * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that * A may be full, upper triangular, lower triangular, upper Hessenberg, * or banded. * * Arguments * ========= * * TYPE (input) CHARACTER*1 * TYPE indices the storage type of the input matrix. * = 'G': A is a full matrix. * = 'L': A is a lower triangular matrix. * = 'U': A is an upper triangular matrix. * = 'H': A is an upper Hessenberg matrix. * = 'B': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the lower * half stored. * = 'Q': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the upper * half stored. * = 'Z': A is a band matrix with lower bandwidth KL and upper * bandwidth KU. * * KL (input) INTEGER * The lower bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * KU (input) INTEGER * The upper bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * CFROM (input) DOUBLE PRECISION * CTO (input) DOUBLE PRECISION * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed * without over/underflow if the final result CTO*A(I,J)/CFROM * can be represented without over/underflow. CFROM must be * nonzero. * * 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,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * INFO (output) INTEGER * 0 - successful exit * <0 - if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of DLASCL * END arpack-akloeckner-07/LAPACK/dlaset.f0000644000175000017500000000621306153460165017061 0ustar andreasandreas SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N DOUBLE PRECISION ALPHA, BETA * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * * Purpose * ======= * * DLASET initializes an m-by-n matrix A to BETA on the diagonal and * ALPHA on the offdiagonals. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be set. * = 'U': Upper triangular part is set; the strictly lower * triangular part of A is not changed. * = 'L': Lower triangular part is set; the strictly upper * triangular part of A is not changed. * Otherwise: All of the matrix A is set. * * 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. * * ALPHA (input) DOUBLE PRECISION * The constant to which the offdiagonal elements are to be set. * * BETA (input) DOUBLE PRECISION * The constant to which the diagonal elements are to be set. * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * On exit, the leading m-by-n submatrix of A is set as follows: * * if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, * if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, * otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, * * and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the strictly upper triangular or trapezoidal part of the * array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the strictly lower triangular or trapezoidal part of the * array to ALPHA. * DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M A( I, J ) = ALPHA 30 CONTINUE 40 CONTINUE * ELSE * * Set the leading m-by-n submatrix to ALPHA. * DO 60 J = 1, N DO 50 I = 1, M A( I, J ) = ALPHA 50 CONTINUE 60 CONTINUE END IF * * Set the first min(M,N) diagonal elements to BETA. * DO 70 I = 1, MIN( M, N ) A( I, I ) = BETA 70 CONTINUE * RETURN * * End of DLASET * END arpack-akloeckner-07/LAPACK/dlasr.f0000644000175000017500000002637306153460165016723 0ustar andreasandreas SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) * .. * * Purpose * ======= * * DLASR performs the transformation * * A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) * * A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) * * where A is an m by n real matrix and P is an orthogonal matrix, * consisting of a sequence of plane rotations determined by the * parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' * and z = n when SIDE = 'R' or 'r' ): * * When DIRECT = 'F' or 'f' ( Forward sequence ) then * * P = P( z - 1 )*...*P( 2 )*P( 1 ), * * and when DIRECT = 'B' or 'b' ( Backward sequence ) then * * P = P( 1 )*P( 2 )*...*P( z - 1 ), * * where P( k ) is a plane rotation matrix for the following planes: * * when PIVOT = 'V' or 'v' ( Variable pivot ), * the plane ( k, k + 1 ) * * when PIVOT = 'T' or 't' ( Top pivot ), * the plane ( 1, k + 1 ) * * when PIVOT = 'B' or 'b' ( Bottom pivot ), * the plane ( k, z ) * * c( k ) and s( k ) must contain the cosine and sine that define the * matrix P( k ). The two by two plane rotation part of the matrix * P( k ), R( k ), is assumed to be of the form * * R( k ) = ( c( k ) s( k ) ). * ( -s( k ) c( k ) ) * * This version vectorises across rows of the array A when SIDE = 'L'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A * = 'R': Right, compute A:= A*P' * * DIRECT (input) CHARACTER*1 * Specifies whether P is a forward or backward sequence of * plane rotations. * = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) * = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation * matrix. * = 'V': Variable pivot, the plane (k,k+1) * = 'T': Top pivot, the plane (1,k+1) * = 'B': Bottom pivot, the plane (k,z) * * M (input) INTEGER * The number of rows of the matrix A. If m <= 1, an immediate * return is effected. * * N (input) INTEGER * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * * C, S (input) DOUBLE PRECISION arrays, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' * c(k) and s(k) contain the cosine and sine that define the * matrix P(k). The two by two plane rotation part of the * matrix P(k), R(k), is assumed to be of the form * R( k ) = ( c( k ) s( k ) ). * ( -s( k ) c( k ) ) * * A (input/output) DOUBLE PRECISION array, dimension (LDA,N) * The m by n matrix A. On exit, A is overwritten by P*A if * SIDE = 'R' or by A*P' if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J DOUBLE PRECISION CTEMP, STEMP, 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( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P' * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of DLASR * END arpack-akloeckner-07/LAPACK/dlasrt.f0000644000175000017500000001442506153460165017102 0ustar andreasandreas SUBROUTINE DLASRT( ID, N, D, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER ID INTEGER INFO, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ) * .. * * Purpose * ======= * * Sort the numbers in D in increasing order (if ID = 'I') or * in decreasing order (if ID = 'D' ). * * Use Quick Sort, reverting to Insertion sort on arrays of * size <= 20. Dimension of STACK limits N to about 2**32. * * Arguments * ========= * * ID (input) CHARACTER*1 * = 'I': sort D in increasing order; * = 'D': sort D in decreasing order. * * N (input) INTEGER * The length of the array D. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the array to be sorted. * On exit, D has been sorted into increasing order * (D(1) <= ... <= D(N) ) or into decreasing order * (D(1) >= ... >= D(N) ), depending on ID. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER SELECT PARAMETER ( SELECT = 20 ) * .. * .. Local Scalars .. INTEGER DIR, ENDD, I, J, START, STKPNT DOUBLE PRECISION D1, D2, D3, DMNMX, TMP * .. * .. Local Arrays .. INTEGER STACK( 2, 32 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input paramters. * INFO = 0 DIR = -1 IF( LSAME( ID, 'D' ) ) THEN DIR = 0 ELSE IF( LSAME( ID, 'I' ) ) THEN DIR = 1 END IF IF( DIR.EQ.-1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DLASRT', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * STKPNT = 1 STACK( 1, 1 ) = 1 STACK( 2, 1 ) = N 10 CONTINUE START = STACK( 1, STKPNT ) ENDD = STACK( 2, STKPNT ) STKPNT = STKPNT - 1 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN * * Do Insertion sort on D( START:ENDD ) * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * DO 30 I = START + 1, ENDD DO 20 J = I, START + 1, -1 IF( D( J ).GT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 30 END IF 20 CONTINUE 30 CONTINUE * ELSE * * Sort into increasing order * DO 50 I = START + 1, ENDD DO 40 J = I, START + 1, -1 IF( D( J ).LT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 50 END IF 40 CONTINUE 50 CONTINUE * END IF * ELSE IF( ENDD-START.GT.SELECT ) THEN * * Partition D( START:ENDD ) and stack parts, largest one first * * Choose partition entry as median of 3 * D1 = D( START ) D2 = D( ENDD ) I = ( START+ENDD ) / 2 D3 = D( I ) IF( D1.LT.D2 ) THEN IF( D3.LT.D1 ) THEN DMNMX = D1 ELSE IF( D3.LT.D2 ) THEN DMNMX = D3 ELSE DMNMX = D2 END IF ELSE IF( D3.LT.D2 ) THEN DMNMX = D2 ELSE IF( D3.LT.D1 ) THEN DMNMX = D3 ELSE DMNMX = D1 END IF END IF * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * I = START - 1 J = ENDD + 1 60 CONTINUE 70 CONTINUE J = J - 1 IF( D( J ).LT.DMNMX ) $ GO TO 70 80 CONTINUE I = I + 1 IF( D( I ).GT.DMNMX ) $ GO TO 80 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 60 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF ELSE * * Sort into increasing order * I = START - 1 J = ENDD + 1 90 CONTINUE 100 CONTINUE J = J - 1 IF( D( J ).GT.DMNMX ) $ GO TO 100 110 CONTINUE I = I + 1 IF( D( I ).LT.DMNMX ) $ GO TO 110 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 90 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF END IF END IF IF( STKPNT.GT.0 ) $ GO TO 10 RETURN * * End of DLASRT * END arpack-akloeckner-07/LAPACK/dlassq.f0000644000175000017500000000514606153460165017100 0ustar andreasandreas SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. DOUBLE PRECISION X( * ) * .. * * Purpose * ======= * * DLASSQ returns the values scl and smsq such that * * ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, * * where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is * assumed to be non-negative and scl returns the value * * scl = max( scale, abs( x( i ) ) ). * * scale and sumsq must be supplied in SCALE and SUMSQ and * scl and smsq are overwritten on SCALE and SUMSQ respectively. * * The routine makes only one pass through the vector x. * * Arguments * ========= * * N (input) INTEGER * The number of elements to be used from the vector X. * * X (input) DOUBLE PRECISION * The vector for which a scaled sum of squares is computed. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. * * INCX (input) INTEGER * The increment between successive values of the vector X. * INCX > 0. * * SCALE (input/output) DOUBLE PRECISION * On entry, the value scale in the equation above. * On exit, SCALE is overwritten with scl , the scaling factor * for the sum of squares. * * SUMSQ (input/output) DOUBLE PRECISION * On entry, the value sumsq in the equation above. * On exit, SUMSQ is overwritten with smsq , the basic sum of * squares from which scl has been factored out. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER IX DOUBLE PRECISION ABSXI * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( X( IX ).NE.ZERO ) THEN ABSXI = ABS( X( IX ) ) IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN * * End of DLASSQ * END arpack-akloeckner-07/LAPACK/dlaswp.f0000644000175000017500000000543106153460165017100 0ustar andreasandreas SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. 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. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IP, IX * .. * .. External Subroutines .. EXTERNAL DSWAP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.EQ.0 ) $ RETURN IF( INCX.GT.0 ) THEN IX = K1 ELSE IX = 1 + ( 1-K2 )*INCX END IF IF( INCX.EQ.1 ) THEN DO 10 I = K1, K2 IP = IPIV( I ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) 10 CONTINUE ELSE IF( INCX.GT.1 ) THEN DO 20 I = K1, K2 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 20 CONTINUE ELSE IF( INCX.LT.0 ) THEN DO 30 I = K2, K1, -1 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 30 CONTINUE END IF * RETURN * * End of DLASWP * END arpack-akloeckner-07/LAPACK/dlasy2.f0000644000175000017500000002761206153460165017011 0ustar andreasandreas SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL LTRANL, LTRANR INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 DOUBLE PRECISION SCALE, XNORM * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), $ X( LDX, * ) * .. * * Purpose * ======= * * DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in * * op(TL)*X + ISGN*X*op(TR) = SCALE*B, * * where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or * -1. op(T) = T or T', where T' denotes the transpose of T. * * Arguments * ========= * * LTRANL (input) LOGICAL * On entry, LTRANL specifies the op(TL): * = .FALSE., op(TL) = TL, * = .TRUE., op(TL) = TL'. * * LTRANR (input) LOGICAL * On entry, LTRANR specifies the op(TR): * = .FALSE., op(TR) = TR, * = .TRUE., op(TR) = TR'. * * ISGN (input) INTEGER * On entry, ISGN specifies the sign of the equation * as described before. ISGN may only be 1 or -1. * * N1 (input) INTEGER * On entry, N1 specifies the order of matrix TL. * N1 may only be 0, 1 or 2. * * N2 (input) INTEGER * On entry, N2 specifies the order of matrix TR. * N2 may only be 0, 1 or 2. * * TL (input) DOUBLE PRECISION array, dimension (LDTL,2) * On entry, TL contains an N1 by N1 matrix. * * LDTL (input) INTEGER * The leading dimension of the matrix TL. LDTL >= max(1,N1). * * TR (input) DOUBLE PRECISION array, dimension (LDTR,2) * On entry, TR contains an N2 by N2 matrix. * * LDTR (input) INTEGER * The leading dimension of the matrix TR. LDTR >= max(1,N2). * * B (input) DOUBLE PRECISION array, dimension (LDB,2) * On entry, the N1 by N2 matrix B contains the right-hand * side of the equation. * * LDB (input) INTEGER * The leading dimension of the matrix B. LDB >= max(1,N1). * * SCALE (output) DOUBLE PRECISION * On exit, SCALE contains the scale factor. SCALE is chosen * less than or equal to 1 to prevent the solution overflowing. * * X (output) DOUBLE PRECISION array, dimension (LDX,2) * On exit, X contains the N1 by N2 solution. * * LDX (input) INTEGER * The leading dimension of the matrix X. LDX >= max(1,N1). * * XNORM (output) DOUBLE PRECISION * On exit, XNORM is the infinity-norm of the solution. * * INFO (output) INTEGER * On exit, INFO is set to * 0: successful exit. * 1: TL and TR have too close eigenvalues, so TL or * TR is perturbed to get a nonsingular equation. * NOTE: In the interests of speed, this routine does not * check the inputs for errors. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) DOUBLE PRECISION TWO, HALF, EIGHT PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) * .. * .. Local Scalars .. LOGICAL BSWAP, XSWAP INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, $ TEMP, U11, U12, U22, XMAX * .. * .. Local Arrays .. LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), $ LOCU22( 4 ) DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) * .. * .. External Functions .. INTEGER IDAMAX DOUBLE PRECISION DLAMCH EXTERNAL IDAMAX, DLAMCH * .. * .. External Subroutines .. EXTERNAL DCOPY, DSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Data statements .. DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , $ LOCU22 / 4, 3, 2, 1 / DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / * .. * .. Executable Statements .. * * Do not check the input parameters for errors * INFO = 0 * * Quick return if possible * IF( N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) / EPS SGN = ISGN * K = N1 + N1 + N2 - 2 GO TO ( 10, 20, 30, 50 )K * * 1 by 1: TL11*X + SGN*X*TR11 = B11 * 10 CONTINUE TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) BET = ABS( TAU1 ) IF( BET.LE.SMLNUM ) THEN TAU1 = SMLNUM BET = SMLNUM INFO = 1 END IF * SCALE = ONE GAM = ABS( B( 1, 1 ) ) IF( SMLNUM*GAM.GT.BET ) $ SCALE = ONE / GAM * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 XNORM = ABS( X( 1, 1 ) ) RETURN * * 1 by 2: * TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] * [TR21 TR22] * 20 CONTINUE * SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) IF( LTRANR ) THEN TMP( 2 ) = SGN*TR( 2, 1 ) TMP( 3 ) = SGN*TR( 1, 2 ) ELSE TMP( 2 ) = SGN*TR( 1, 2 ) TMP( 3 ) = SGN*TR( 2, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 1, 2 ) GO TO 40 * * 2 by 1: * op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] * [TL21 TL22] [X21] [X21] [B21] * 30 CONTINUE SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) IF( LTRANL ) THEN TMP( 2 ) = TL( 1, 2 ) TMP( 3 ) = TL( 2, 1 ) ELSE TMP( 2 ) = TL( 2, 1 ) TMP( 3 ) = TL( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) 40 CONTINUE * * Solve 2 by 2 system using complete pivoting. * Set pivots less than SMIN to SMIN. * IPIV = IDAMAX( 4, TMP, 1 ) U11 = TMP( IPIV ) IF( ABS( U11 ).LE.SMIN ) THEN INFO = 1 U11 = SMIN END IF U12 = TMP( LOCU12( IPIV ) ) L21 = TMP( LOCL21( IPIV ) ) / U11 U22 = TMP( LOCU22( IPIV ) ) - U12*L21 XSWAP = XSWPIV( IPIV ) BSWAP = BSWPIV( IPIV ) IF( ABS( U22 ).LE.SMIN ) THEN INFO = 1 U22 = SMIN END IF IF( BSWAP ) THEN TEMP = BTMP( 2 ) BTMP( 2 ) = BTMP( 1 ) - L21*TEMP BTMP( 1 ) = TEMP ELSE BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) END IF SCALE = ONE IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE END IF X2( 2 ) = BTMP( 2 ) / U22 X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) IF( XSWAP ) THEN TEMP = X2( 2 ) X2( 2 ) = X2( 1 ) X2( 1 ) = TEMP END IF X( 1, 1 ) = X2( 1 ) IF( N1.EQ.1 ) THEN X( 1, 2 ) = X2( 2 ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) ELSE X( 2, 1 ) = X2( 2 ) XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) END IF RETURN * * 2 by 2: * op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] * [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] * * Solve equivalent 4 by 4 system using complete pivoting. * Set pivots less than SMIN to SMIN. * 50 CONTINUE SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) SMIN = MAX( EPS*SMIN, SMLNUM ) BTMP( 1 ) = ZERO CALL DCOPY( 16, BTMP, 0, T16, 1 ) T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) IF( LTRANL ) THEN T16( 1, 2 ) = TL( 2, 1 ) T16( 2, 1 ) = TL( 1, 2 ) T16( 3, 4 ) = TL( 2, 1 ) T16( 4, 3 ) = TL( 1, 2 ) ELSE T16( 1, 2 ) = TL( 1, 2 ) T16( 2, 1 ) = TL( 2, 1 ) T16( 3, 4 ) = TL( 1, 2 ) T16( 4, 3 ) = TL( 2, 1 ) END IF IF( LTRANR ) THEN T16( 1, 3 ) = SGN*TR( 1, 2 ) T16( 2, 4 ) = SGN*TR( 1, 2 ) T16( 3, 1 ) = SGN*TR( 2, 1 ) T16( 4, 2 ) = SGN*TR( 2, 1 ) ELSE T16( 1, 3 ) = SGN*TR( 2, 1 ) T16( 2, 4 ) = SGN*TR( 2, 1 ) T16( 3, 1 ) = SGN*TR( 1, 2 ) T16( 4, 2 ) = SGN*TR( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) BTMP( 3 ) = B( 1, 2 ) BTMP( 4 ) = B( 2, 2 ) * * Perform elimination * DO 100 I = 1, 3 XMAX = ZERO DO 70 IP = I, 4 DO 60 JP = I, 4 IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T16( IP, JP ) ) IPSV = IP JPSV = JP END IF 60 CONTINUE 70 CONTINUE IF( IPSV.NE.I ) THEN CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T16( I, I ) ).LT.SMIN ) THEN INFO = 1 T16( I, I ) = SMIN END IF DO 90 J = I + 1, 4 T16( J, I ) = T16( J, I ) / T16( I, I ) BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) DO 80 K = I + 1, 4 T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) 80 CONTINUE 90 CONTINUE 100 CONTINUE IF( ABS( T16( 4, 4 ) ).LT.SMIN ) $ T16( 4, 4 ) = SMIN SCALE = ONE IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE BTMP( 4 ) = BTMP( 4 )*SCALE END IF DO 120 I = 1, 4 K = 5 - I TEMP = ONE / T16( K, K ) TMP( K ) = BTMP( K )*TEMP DO 110 J = K + 1, 4 TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) 110 CONTINUE 120 CONTINUE DO 130 I = 1, 3 IF( JPIV( 4-I ).NE.4-I ) THEN TEMP = TMP( 4-I ) TMP( 4-I ) = TMP( JPIV( 4-I ) ) TMP( JPIV( 4-I ) ) = TEMP END IF 130 CONTINUE X( 1, 1 ) = TMP( 1 ) X( 2, 1 ) = TMP( 2 ) X( 1, 2 ) = TMP( 3 ) X( 2, 2 ) = TMP( 4 ) XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) RETURN * * End of DLASY2 * END arpack-akloeckner-07/LAPACK/dorm2r.f0000644000175000017500000001224606153460166017016 0ustar andreasandreas SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * DORM2R overwrites the general real m by n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'T', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'T', * * where Q is a real orthogonal matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'T': apply Q' (Transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * DGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) DOUBLE PRECISION array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by DGEQRF. * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) DOUBLE PRECISION array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * 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 LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ DOUBLE PRECISION AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DORM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of DORM2R * END arpack-akloeckner-07/LAPACK/dpttrf.f0000644000175000017500000000602506153460166017112 0ustar andreasandreas SUBROUTINE DPTTRF( N, D, E, INFO ) * * -- LAPACK routine (version 2.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, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ) * .. * * Purpose * ======= * * DPTTRF computes the factorization of a real symmetric positive * definite tridiagonal matrix A. * * If the subdiagonal elements of A are supplied in the array E, the * factorization has the form A = L*D*L**T, where D is diagonal and L * is unit lower bidiagonal; if the superdiagonal elements of A are * supplied, it has the form A = U**T*D*U, where U is unit upper * bidiagonal. (The two forms are equivalent if A is real.) * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the n diagonal elements of the tridiagonal matrix * A. On exit, the n diagonal elements of the diagonal matrix * D from the L*D*L**T factorization of A. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the (n-1) off-diagonal elements of the tridiagonal * matrix A. * On exit, the (n-1) off-diagonal elements of the unit * bidiagonal factor L or U from the factorization of A. * * 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; if i < N, the factorization could * not be completed, while if i = N, the factorization was * completed, but D(N) = 0. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I DOUBLE PRECISION DI, EI * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'DPTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Compute the L*D*L' (or U'*D*U) factorization of A. * DO 10 I = 1, N - 1 * * Drop out of the loop if d(i) <= 0: the matrix is not positive * definite. * DI = D( I ) IF( DI.LE.ZERO ) $ GO TO 20 * * Solve for e(i) and d(i+1). * EI = E( I ) E( I ) = EI / DI D( I+1 ) = D( I+1 ) - E( I )*EI 10 CONTINUE * * Check d(n) for positive definiteness. * I = N IF( D( I ).GT.ZERO ) $ GO TO 30 * 20 CONTINUE INFO = I * 30 CONTINUE RETURN * * End of DPTTRF * END arpack-akloeckner-07/LAPACK/dpttrs.f0000644000175000017500000000560106153460166017126 0ustar andreasandreas SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * * -- LAPACK routine (version 2.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, LDB, N, NRHS * .. * .. Array Arguments .. DOUBLE PRECISION B( LDB, * ), D( * ), E( * ) * .. * * Purpose * ======= * * DPTTRS solves a system of linear equations A * X = B with a * symmetric positive definite tridiagonal matrix A using the * factorization A = L*D*L**T or A = U**T*D*U computed by DPTTRF. * (The two forms are equivalent if A is real.) * * Arguments * ========= * * N (input) INTEGER * The order of the tridiagonal 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. * * D (input) DOUBLE PRECISION array, dimension (N) * The n diagonal elements of the diagonal matrix D from the * factorization computed by DPTTRF. * * E (input) DOUBLE PRECISION array, dimension (N-1) * The (n-1) off-diagonal elements of the unit bidiagonal factor * U or L from the factorization computed by DPTTRF. * * 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 * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DPTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Solve A * X = B using the factorization A = L*D*L', * overwriting each right hand side vector with its solution. * DO 30 J = 1, NRHS * * Solve L * x = b. * DO 10 I = 2, N B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 ) 10 CONTINUE * * Solve D * L' * x = b. * B( N, J ) = B( N, J ) / D( N ) DO 20 I = N - 1, 1, -1 B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I ) 20 CONTINUE 30 CONTINUE * RETURN * * End of DPTTRS * END arpack-akloeckner-07/LAPACK/dsteqr.f0000644000175000017500000003305006153460166017107 0ustar andreasandreas SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * DSTEQR computes all eigenvalues and, optionally, eigenvectors of a * symmetric tridiagonal matrix using the implicit QL or QR method. * The eigenvectors of a full or band symmetric matrix can also be found * if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to * tridiagonal form. * * Arguments * ========= * * COMPZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only. * = 'V': Compute eigenvalues and eigenvectors of the original * symmetric matrix. On entry, Z must contain the * orthogonal matrix used to reduce the original matrix * to tridiagonal form. * = 'I': Compute eigenvalues and eigenvectors of the * tridiagonal matrix. Z is initialized to the identity * matrix. * * N (input) INTEGER * The order of the matrix. N >= 0. * * D (input/output) DOUBLE PRECISION array, dimension (N) * On entry, the diagonal elements of the tridiagonal matrix. * On exit, if INFO = 0, the eigenvalues in ascending order. * * E (input/output) DOUBLE PRECISION array, dimension (N-1) * On entry, the (n-1) subdiagonal elements of the tridiagonal * matrix. * On exit, E has been destroyed. * * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) * On entry, if COMPZ = 'V', then Z contains the orthogonal * matrix used in the reduction to tridiagonal form. * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the * orthonormal eigenvectors of the original symmetric matrix, * and if COMPZ = 'I', Z contains the orthonormal eigenvectors * of the symmetric tridiagonal matrix. * If COMPZ = 'N', then Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * eigenvectors are desired, then LDZ >= max(1,N). * * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) * If COMPZ = 'N', then WORK is not referenced. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: the algorithm has failed to find all the eigenvalues in * a total of 30*N iterations; if INFO = i, then i * elements of E have not converged to zero; on exit, D * and E contain the elements of a symmetric tridiagonal * matrix which is orthogonally similar to the original * matrix. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, $ THREE = 3.0D0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 * .. * .. External Subroutines .. EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, $ DLASRT, DSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = ONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = DLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = DLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = DLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL DLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.LT.NMAXIT ) $ GO TO 10 DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE GO TO 190 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL DLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF * 190 CONTINUE RETURN * * End of DSTEQR * END arpack-akloeckner-07/LAPACK/lsame.f0000644000175000017500000000466006153460167016714 0ustar andreasandreas LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END arpack-akloeckner-07/LAPACK/dtrevc.f0000644000175000017500000010427706153460166017106 0ustar andreasandreas SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * Purpose * ======= * * DTREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: * * T*x = w*x, y'*T = w*y' * * where y' denotes the conjugate transpose of the vector y. * * If all eigenvectors are requested, the routine may either return the * matrices X and/or Y of right or left eigenvectors of T, or the * products Q*X and/or Q*Y, where Q is an input orthogonal * matrix. If T was obtained from the real-Schur factorization of an * original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of * right or left eigenvectors of A. * * T must be in Schur canonical form (as returned by DHSEQR), that is, * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each * 2-by-2 diagonal block has its diagonal elements equal and its * off-diagonal elements of opposite sign. Corresponding to each 2-by-2 * diagonal block is a complex conjugate pair of eigenvalues and * eigenvectors; only one eigenvector of the pair is computed, namely * the one corresponding to the eigenvalue with positive imaginary part. * * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'R': compute right eigenvectors only; * = 'L': compute left eigenvectors only; * = 'B': compute both right and left eigenvectors. * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, * and backtransform them using the input matrices * supplied in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. * If HOWMNY = 'A' or 'B', SELECT is not referenced. * To select the real eigenvector corresponding to a real * eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select * the complex eigenvector corresponding to a complex conjugate * pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be * set to .TRUE.; then on exit SELECT(j) is .TRUE. and * SELECT(j+1) is .FALSE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input) DOUBLE PRECISION array, dimension (LDT,N) * The upper quasi-triangular matrix T in Schur canonical form. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= max(1,N) if * SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of Schur vectors returned by DHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= max(1,N) if * SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) INTEGER * The number of columns in the arrays VL and/or VR actually * used to store the eigenvectors. * If HOWMNY = 'A' or 'B', M is set to N. * Each selected real eigenvector occupies one column and each * selected complex eigenvector occupies two columns. * * WORK (workspace) DOUBLE PRECISION array, dimension (3*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The algorithm used in this program is basically backward (forward) * substitution, with scaling to make the the code robust against * possible overflow. * * Each eigenvector is normalized so that the element of largest * magnitude has magnitude 1; here the magnitude of a complex number * (x,y) is taken to be |x| + |y|. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, $ XNORM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX DOUBLE PRECISION DDOT, DLAMCH EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH * .. * .. External Subroutines .. EXTERNAL DAXPY, DCOPY, DGEMV, DLABAD, DLALN2, DSCAL, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Local Arrays .. DOUBLE PRECISION X( 2, 2 ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'O' ) SOMEV = LSAME( HOWMNY, 'S' ) * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE * * Set M to the number of columns required to store the selected * eigenvectors, standardize the array SELECT if necessary, and * test MM. * IF( SOMEV ) THEN M = 0 PAIR = .FALSE. DO 10 J = 1, N IF( PAIR ) THEN PAIR = .FALSE. SELECT( J ) = .FALSE. ELSE IF( J.LT.N ) THEN IF( T( J+1, J ).EQ.ZERO ) THEN IF( SELECT( J ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN SELECT( J ) = .TRUE. M = M + 2 END IF END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE ELSE M = N END IF * IF( MM.LT.M ) THEN INFO = -11 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set the constants to control overflow. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) BIGNUM = ( ONE-ULP ) / SMLNUM * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * WORK( 1 ) = ZERO DO 30 J = 2, N WORK( J ) = ZERO DO 20 I = 1, J - 1 WORK( J ) = WORK( J ) + ABS( T( I, J ) ) 20 CONTINUE 30 CONTINUE * * Index IP is used to specify the real or complex eigenvalue: * IP = 0, real eigenvalue, * 1, first of conjugate complex pair: (wr,wi) * -1, second of conjugate complex pair: (wr,wi) * N2 = 2*N * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IP = 0 IS = M DO 140 KI = N, 1, -1 * IF( IP.EQ.1 ) $ GO TO 130 IF( KI.EQ.1 ) $ GO TO 40 IF( T( KI, KI-1 ).EQ.ZERO ) $ GO TO 40 IP = -1 * 40 CONTINUE IF( SOMEV ) THEN IF( IP.EQ.0 ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 ELSE IF( .NOT.SELECT( KI-1 ) ) $ GO TO 130 END IF END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* $ SQRT( ABS( T( KI-1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real right eigenvector * WORK( KI+N ) = ONE * * Form right-hand side * DO 50 K = 1, KI - 1 WORK( K+N ) = -T( K, KI ) 50 CONTINUE * * Solve the upper quasi-triangular system: * (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. * JNXT = KI - 1 DO 60 J = KI - 1, 1, -1 IF( J.GT.JNXT ) $ GO TO 60 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J+N ) = X( 1, 1 ) * * Update right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, ZERO, X, 2, $ SCALE, XNORM, IERR ) * * Scale X(1,1) and X(2,1) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 2, 1 ) = X( 2, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) * * Update right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) END IF 60 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) * II = IDAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / ABS( VR( II, IS ) ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 70 K = KI + 1, N VR( K, IS ) = ZERO 70 CONTINUE ELSE IF( KI.GT.1 ) $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI+N ), $ VR( 1, KI ), 1 ) * II = IDAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / ABS( VR( II, KI ) ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF * ELSE * * Complex right eigenvector. * * Initial solve * [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. * [ (T(KI,KI-1) T(KI,KI) ) ] * IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN WORK( KI-1+N ) = ONE WORK( KI+N2 ) = WI / T( KI-1, KI ) ELSE WORK( KI-1+N ) = -WI / T( KI, KI-1 ) WORK( KI+N2 ) = ONE END IF WORK( KI+N ) = ZERO WORK( KI-1+N2 ) = ZERO * * Form right-hand side * DO 80 K = 1, KI - 2 WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) 80 CONTINUE * * Solve upper quasi-triangular system: * (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) * JNXT = KI - 2 DO 90 J = KI - 2, 1, -1 IF( J.GT.JNXT ) $ GO TO 90 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, $ X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) and X(1,2) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 1, 2 ) = X( 1, 2 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) * * Update the right-hand side * CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL DLALN2( .FALSE., 2, 2, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, $ XNORM, IERR ) * * Scale X to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN REC = ONE / XNORM X( 1, 1 ) = X( 1, 1 )*REC X( 1, 2 ) = X( 1, 2 )*REC X( 2, 1 ) = X( 2, 1 )*REC X( 2, 2 ) = X( 2, 2 )*REC SCALE = SCALE*REC END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) WORK( J-1+N2 ) = X( 1, 2 ) WORK( J+N2 ) = X( 2, 2 ) * * Update the right-hand side * CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, $ WORK( 1+N2 ), 1 ) CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) END IF 90 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) * EMAX = ZERO DO 100 K = 1, KI EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ $ ABS( VR( K, IS ) ) ) 100 CONTINUE * REMAX = ONE / EMAX CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 110 K = KI + 1, N VR( K, IS-1 ) = ZERO VR( K, IS ) = ZERO 110 CONTINUE * ELSE * IF( KI.GT.2 ) THEN CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI-1+N ), $ VR( 1, KI-1 ), 1 ) CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N2 ), 1, WORK( KI+N2 ), $ VR( 1, KI ), 1 ) ELSE CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) END IF * EMAX = ZERO DO 120 K = 1, N EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ $ ABS( VR( K, KI ) ) ) 120 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) CALL DSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF END IF * IS = IS - 1 IF( IP.NE.0 ) $ IS = IS - 1 130 CONTINUE IF( IP.EQ.1 ) $ IP = 0 IF( IP.EQ.-1 ) $ IP = 1 140 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IP = 0 IS = 1 DO 260 KI = 1, N * IF( IP.EQ.-1 ) $ GO TO 250 IF( KI.EQ.N ) $ GO TO 150 IF( T( KI+1, KI ).EQ.ZERO ) $ GO TO 150 IP = 1 * 150 CONTINUE IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 250 END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* $ SQRT( ABS( T( KI+1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real left eigenvector. * WORK( KI+N ) = ONE * * Form right-hand side * DO 160 K = KI + 1, N WORK( K+N ) = -T( KI, K ) 160 CONTINUE * * Solve the quasi-triangular system: * (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 1 DO 170 J = KI + 1, N IF( J.LT.JNXT ) $ GO TO 170 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * * Solve (T(J,J)-WR)'*X = WORK * CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, $ WORK( KI+1+N ), 1 ) * * Solve * [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) * [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) WORK( J+1+N ) = X( 2, 1 ) * VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+1+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 170 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) * II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / ABS( VL( II, IS ) ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 180 K = 1, KI - 1 VL( K, IS ) = ZERO 180 CONTINUE * ELSE * IF( KI.LT.N ) $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) * II = IDAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / ABS( VL( II, KI ) ) CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) * END IF * ELSE * * Complex left eigenvector. * * Initial solve: * ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. * ((T(KI+1,KI) T(KI+1,KI+1)) ) * IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN WORK( KI+N ) = WI / T( KI, KI+1 ) WORK( KI+1+N2 ) = ONE ELSE WORK( KI+N ) = ONE WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) END IF WORK( KI+1+N ) = ZERO WORK( KI+N2 ) = ZERO * * Form right-hand side * DO 190 K = KI + 2, N WORK( K+N ) = -WORK( KI+N )*T( KI, K ) WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) 190 CONTINUE * * Solve complex quasi-triangular system: * ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 2 DO 200 J = KI + 2, N IF( J.LT.JNXT ) $ GO TO 200 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when * forming the right-hand side elements. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 * CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+N2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side elements. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+N2 ) = WORK( J+N2 ) - $ DDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+1+N2 ) = WORK( J+1+N2 ) - $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve 2-by-2 complex linear equation * ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B * ([T(j+1,j) T(j+1,j+1)] ) * CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) WORK( J+1+N ) = X( 2, 1 ) WORK( J+1+N2 ) = X( 2, 2 ) VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 200 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * 210 CONTINUE IF( .NOT.OVER ) THEN CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), $ 1 ) * EMAX = ZERO DO 220 K = KI, N EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ $ ABS( VL( K, IS+1 ) ) ) 220 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) * DO 230 K = 1, KI - 1 VL( K, IS ) = ZERO VL( K, IS+1 ) = ZERO 230 CONTINUE ELSE IF( KI.LT.N-1 ) THEN CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N2 ), 1, $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) ELSE CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) END IF * EMAX = ZERO DO 240 K = 1, N EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ $ ABS( VL( K, KI+1 ) ) ) 240 CONTINUE REMAX = ONE / EMAX CALL DSCAL( N, REMAX, VL( 1, KI ), 1 ) CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) * END IF * END IF * IS = IS + 1 IF( IP.NE.0 ) $ IS = IS + 1 250 CONTINUE IF( IP.EQ.-1 ) $ IP = 0 IF( IP.EQ.1 ) $ IP = -1 * 260 CONTINUE * END IF * RETURN * * End of DTREVC * END arpack-akloeckner-07/LAPACK/dtrexc.f0000644000175000017500000002420306153460166017076 0ustar andreasandreas SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * Purpose * ======= * * DTREXC reorders the real Schur factorization of a real matrix * A = Q*T*Q**T, so that the diagonal block of T with row index IFST is * moved to row ILST. * * The real Schur form T is reordered by an orthogonal similarity * transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors * is updated by postmultiplying it with Z. * * T must be in Schur canonical form (as returned by DHSEQR), that is, * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each * 2-by-2 diagonal block has its diagonal elements equal and its * off-diagonal elements of opposite sign. * * Arguments * ========= * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) DOUBLE PRECISION array, dimension (LDT,N) * On entry, the upper quasi-triangular matrix T, in Schur * Schur canonical form. * On exit, the reordered upper quasi-triangular matrix, again * in Schur canonical form. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * orthogonal transformation matrix Z which reorders T. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= max(1,N). * * IFST (input/output) INTEGER * ILST (input/output) INTEGER * Specify the reordering of the diagonal blocks of T. * The block with row index IFST is moved to row ILST, by a * sequence of transpositions between adjacent blocks. * On exit, if IFST pointed on entry to the second row of a * 2-by-2 block, it is changed to point to the first row; ILST * always points to the first row of the block in its final * position (which may differ from its input value by +1 or -1). * 1 <= IFST <= N; 1 <= ILST <= N. * * WORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1: two adjacent blocks were too close to swap (the problem * is very ill-conditioned); T may have been partially * reordered, and ILST points to the first row of the * current position of the block being moved. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. LOGICAL WANTQ INTEGER HERE, NBF, NBL, NBNEXT * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL DLAEXC, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test the input arguments. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -7 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Determine the first row of specified block * and find out it is 1 by 1 or 2 by 2. * IF( IFST.GT.1 ) THEN IF( T( IFST, IFST-1 ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.N ) THEN IF( T( IFST+1, IFST ).NE.ZERO ) $ NBF = 2 END IF * * Determine the first row of the final block * and find out it is 1 by 1 or 2 by 2. * IF( ILST.GT.1 ) THEN IF( T( ILST, ILST-1 ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.N ) THEN IF( T( ILST+1, ILST ).NE.ZERO ) $ NBL = 2 END IF * IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Update ILST * IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 * HERE = IFST * 10 CONTINUE * * Swap block with next one below * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE+NBF+1.LE.N ) THEN IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE+3.LE.N ) THEN IF( T( HERE+3, HERE+2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, $ WORK, INFO ) HERE = HERE + 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE+2, HERE+1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, $ NBNEXT, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE * * 2 by 2 Block did split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, $ WORK, INFO ) HERE = HERE + 2 END IF END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 * ELSE * HERE = IFST 20 CONTINUE * * Swap block with next one above * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ NBF, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ 1, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, $ WORK, INFO ) HERE = HERE - 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE, HERE-1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE * * 2 by 2 Block did split * CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, $ WORK, INFO ) HERE = HERE - 2 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE * RETURN * * End of DTREXC * END arpack-akloeckner-07/LAPACK/dtrsen.f0000644000175000017500000003413006153460166017104 0ustar andreasandreas SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N DOUBLE PRECISION S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), $ WR( * ) * .. * * Purpose * ======= * * DTRSEN reorders the real Schur factorization of a real matrix * A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in * the leading diagonal blocks of the upper quasi-triangular matrix T, * and the leading columns of Q form an orthonormal basis of the * corresponding right invariant subspace. * * Optionally the routine computes the reciprocal condition numbers of * the cluster of eigenvalues and/or the invariant subspace. * * T must be in Schur canonical form (as returned by DHSEQR), that is, * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each * 2-by-2 diagonal block has its diagonal elemnts equal and its * off-diagonal elements of opposite sign. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies whether condition numbers are required for the * cluster of eigenvalues (S) or the invariant subspace (SEP): * = 'N': none; * = 'E': for eigenvalues only (S); * = 'V': for invariant subspace only (SEP); * = 'B': for both eigenvalues and invariant subspace (S and * SEP). * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * SELECT (input) LOGICAL array, dimension (N) * SELECT specifies the eigenvalues in the selected cluster. To * select a real eigenvalue w(j), SELECT(j) must be set to * .TRUE.. To select a complex conjugate pair of eigenvalues * w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, * either SELECT(j) or SELECT(j+1) or both must be set to * .TRUE.; a complex conjugate pair of eigenvalues must be * either both included in the cluster or both excluded. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) DOUBLE PRECISION array, dimension (LDT,N) * On entry, the upper quasi-triangular matrix T, in Schur * canonical form. * On exit, T is overwritten by the reordered matrix T, again in * Schur canonical form, with the selected eigenvalues in the * leading diagonal blocks. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * orthogonal transformation matrix which reorders T; the * leading M columns of Q form an orthonormal basis for the * specified invariant subspace. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= 1; and if COMPQ = 'V', LDQ >= N. * * WR (output) DOUBLE PRECISION array, dimension (N) * WI (output) DOUBLE PRECISION array, dimension (N) * The real and imaginary parts, respectively, of the reordered * eigenvalues of T. The eigenvalues are stored in the same * order as on the diagonal of T, with WR(i) = T(i,i) and, if * T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and * WI(i+1) = -WI(i). Note that if a complex eigenvalue is * sufficiently ill-conditioned, then its value may differ * significantly from its value before reordering. * * M (output) INTEGER * The dimension of the specified invariant subspace. * 0 < = M <= N. * * S (output) DOUBLE PRECISION * If JOB = 'E' or 'B', S is a lower bound on the reciprocal * condition number for the selected cluster of eigenvalues. * S cannot underestimate the true reciprocal condition number * by more than a factor of sqrt(N). If M = 0 or N, S = 1. * If JOB = 'N' or 'V', S is not referenced. * * SEP (output) DOUBLE PRECISION * If JOB = 'V' or 'B', SEP is the estimated reciprocal * condition number of the specified invariant subspace. If * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= max(1,N); * if JOB = 'E', LWORK >= M*(N-M); * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). * * IWORK (workspace) INTEGER array, dimension (LIWORK) * IF JOB = 'N' or 'E', IWORK is not referenced. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * If JOB = 'N' or 'E', LIWORK >= 1; * if JOB = 'V' or 'B', LIWORK >= M*(N-M). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1: reordering of T failed because some eigenvalues are too * close to separate (the problem is very ill-conditioned); * T may have been partially reordered, and WR and WI * contain the eigenvalues in the same order as in T; S and * SEP (if requested) are set to zero. * * Further Details * =============== * * DTRSEN first collects the selected eigenvalues by computing an * orthogonal transformation Z to move them to the top left corner of T. * In other words, the selected eigenvalues are the eigenvalues of T11 * in: * * Z'*T*Z = ( T11 T12 ) n1 * ( 0 T22 ) n2 * n1 n2 * * where N = n1+n2 and Z' means the transpose of Z. The first n1 columns * of Z span the specified invariant subspace of T. * * If T has been obtained from the real Schur factorization of a matrix * A = Q*T*Q', then the reordered real Schur factorization of A is given * by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span * the corresponding invariant subspace of A. * * The reciprocal condition number of the average of the eigenvalues of * T11 may be returned in S. S lies between 0 (very badly conditioned) * and 1 (very well conditioned). It is computed as follows. First we * compute R so that * * P = ( I R ) n1 * ( 0 0 ) n2 * n1 n2 * * is the projector on the invariant subspace associated with T11. * R is the solution of the Sylvester equation: * * T11*R - R*T22 = T12. * * Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote * the two-norm of M. Then S is computed as the lower bound * * (1 + F-norm(R)**2)**(-1/2) * * on the reciprocal of 2-norm(P), the true reciprocal condition number. * S cannot underestimate 1 / 2-norm(P) by more than a factor of * sqrt(N). * * An approximate error bound for the computed average of the * eigenvalues of T11 is * * EPS * norm(T) / S * * where EPS is the machine precision. * * The reciprocal condition number of the right invariant subspace * spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. * SEP is defined as the separation of T11 and T22: * * sep( T11, T22 ) = sigma-min( C ) * * where sigma-min(C) is the smallest singular value of the * n1*n2-by-n1*n2 matrix * * C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) * * I(m) is an m by m identity matrix, and kprod denotes the Kronecker * product. We estimate sigma-min(C) by the reciprocal of an estimate of * the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) * cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). * * When SEP is small, small changes in T can cause large changes in * the invariant subspace. An approximate bound on the maximum angular * error in the computed right invariant subspace is * * EPS * norm(T) / SEP * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL PAIR, SWAP, WANTBH, WANTQ, WANTS, WANTSP INTEGER IERR, K, KASE, KK, KS, N1, N2, NN DOUBLE PRECISION EST, RNORM, SCALE * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLANGE EXTERNAL LSAME, DLANGE * .. * .. External Subroutines .. EXTERNAL DLACON, DLACPY, DTREXC, DTRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE * * Set M to the dimension of the specified invariant subspace, * and test LWORK and LIWORK. * M = 0 PAIR = .FALSE. DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( T( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * IF( LWORK.LT.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND. $ LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN INFO = -15 ELSE IF( LIWORK.LT.1 .OR. ( WANTSP .AND. LIWORK.LT.NN ) ) THEN INFO = -17 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRSEN', -INFO ) RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = DLANGE( '1', N, N, T, LDT, WORK ) GO TO 40 END IF * * Collect the selected blocks at the top-left corner of T. * KS = 0 PAIR = .FALSE. DO 20 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT( K ) IF( K.LT.N ) THEN IF( T( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( K+1 ) END IF END IF IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. * IERR = 0 KK = K IF( K.NE.KS ) $ CALL DTREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK, $ IERR ) IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN * * Blocks too close to swap: exit. * INFO = 1 IF( WANTS ) $ S = ZERO IF( WANTSP ) $ SEP = ZERO GO TO 40 END IF IF( PAIR ) $ KS = KS + 1 END IF END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL DLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = DLANGE( 'F', N1, N2, WORK, N1, WORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL DLACON( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11'*R - R*T22' = scale*X. * CALL DTRSYL( 'T', 'T', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Store the output eigenvalues in WR and WI. * DO 50 K = 1, N WR( K ) = T( K, K ) WI( K ) = ZERO 50 CONTINUE DO 60 K = 1, N - 1 IF( T( K+1, K ).NE.ZERO ) THEN WI( K ) = SQRT( ABS( T( K, K+1 ) ) )* $ SQRT( ABS( T( K+1, K ) ) ) WI( K+1 ) = -WI( K ) END IF 60 CONTINUE RETURN * * End of DTRSEN * END arpack-akloeckner-07/LAPACK/dtrsyl.f0000644000175000017500000010140406153460167017126 0ustar andreasandreas SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DTRSYL solves the real Sylvester matrix equation: * * op(A)*X + X*op(B) = scale*C or * op(A)*X - X*op(B) = scale*C, * * where op(A) = A or A**T, and A and B are both upper quasi- * triangular. A is M-by-M and B is N-by-N; the right hand side C and * the solution X are M-by-N; and scale is an output scale factor, set * <= 1 to avoid overflow in X. * * A and B must be in Schur canonical form (as returned by DHSEQR), that * is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; * each 2-by-2 diagonal block has its diagonal elements equal and its * off-diagonal elements of opposite sign. * * Arguments * ========= * * TRANA (input) CHARACTER*1 * Specifies the option op(A): * = 'N': op(A) = A (No transpose) * = 'T': op(A) = A**T (Transpose) * = 'C': op(A) = A**H (Conjugate transpose = Transpose) * * TRANB (input) CHARACTER*1 * Specifies the option op(B): * = 'N': op(B) = B (No transpose) * = 'T': op(B) = B**T (Transpose) * = 'C': op(B) = B**H (Conjugate transpose = Transpose) * * ISGN (input) INTEGER * Specifies the sign in the equation: * = +1: solve op(A)*X + X*op(B) = scale*C * = -1: solve op(A)*X - X*op(B) = scale*C * * M (input) INTEGER * The order of the matrix A, and the number of rows in the * matrices X and C. M >= 0. * * N (input) INTEGER * The order of the matrix B, and the number of columns in the * matrices X and C. N >= 0. * * A (input) DOUBLE PRECISION array, dimension (LDA,M) * The upper quasi-triangular matrix A, in Schur canonical form. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (input) DOUBLE PRECISION array, dimension (LDB,N) * The upper quasi-triangular matrix B, in Schur canonical form. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) * On entry, the M-by-N right hand side matrix C. * On exit, C is overwritten by the solution matrix X. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M) * * SCALE (output) DOUBLE PRECISION * The scale factor, scale, set <= 1 to avoid overflow in X. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1: A and B have common or very close eigenvalues; perturbed * values were used to solve the equation (but the matrices * A and B are unchanged). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM, SUML, SUMR, XNORM * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DDOT, DLAMCH, DLANGE EXTERNAL LSAME, DDOT, DLAMCH, DLANGE * .. * .. External Subroutines .. EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. $ LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. $ LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'DTRSYL', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( M*N ) / EPS BIGNUM = ONE / SMLNUM * SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) * SCALE = ONE SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * * Start column loop (index = L) * L1 (L2) : column index of the first (first) row of X(K,L). * LNEXT = 1 DO 60 L = 1, N IF( L.LT.LNEXT ) $ GO TO 60 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L). * KNEXT = M DO 50 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 50 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 20 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 20 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 30 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 30 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .FALSE., .FALSE., ISGN, 2, 2, $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, $ 2, SCALOC, X, 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 50 CONTINUE * 60 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A' *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 L-1 * R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = 1 DO 120 L = 1, N IF( L.LT.LNEXT ) $ GO TO 120 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 110 K = 1, M IF( K.LT.KNEXT ) $ GO TO 110 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 70 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 80 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 80 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 90 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 110 CONTINUE 120 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A'*X + ISGN*X*B' = scale*C. * * The (K,L)th block of X is determined starting from * top-right corner column by column by * * A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) * * Where * K-1 N * R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. * I=1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 180 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 180 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 170 K = 1, M IF( K.LT.KNEXT ) $ GO TO 170 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 130 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 130 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 140 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 140 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 150 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 150 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 160 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 160 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 170 CONTINUE 180 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B' = scale*C. * * The (K,L)th block of X is determined starting from * bottom-right corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. * I=K+1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 240 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 240 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = M DO 230 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 230 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 190 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 190 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 200 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 200 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 210 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 210 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL DLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 220 J = 1, N CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) 220 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 230 CONTINUE 240 CONTINUE * END IF * RETURN * * End of DTRSYL * END arpack-akloeckner-07/LAPACK/dzsum1.f0000644000175000017500000000347106153460167017035 0ustar andreasandreas DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX*16 CX( * ) * .. * * Purpose * ======= * * DZSUM1 takes the sum of the absolute values of a complex * vector and returns a double precision result. * * Based on DZASUM from the Level 1 BLAS. * The change is to use the 'genuine' absolute value. * * Contributed by Nick Higham for use with ZLACON. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vector CX. * * CX (input) COMPLEX*16 array, dimension (N) * The vector whose elements will be summed. * * INCX (input) INTEGER * The spacing between successive values of CX. INCX > 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, NINCX DOUBLE PRECISION STEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * DZSUM1 = 0.0D0 STEMP = 0.0D0 IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 ) $ GO TO 20 * * CODE FOR INCREMENT NOT EQUAL TO 1 * NINCX = N*INCX DO 10 I = 1, NINCX, INCX * * NEXT LINE MODIFIED. * STEMP = STEMP + ABS( CX( I ) ) 10 CONTINUE DZSUM1 = STEMP RETURN * * CODE FOR INCREMENT EQUAL TO 1 * 20 CONTINUE DO 30 I = 1, N * * NEXT LINE MODIFIED. * STEMP = STEMP + ABS( CX( I ) ) 30 CONTINUE DZSUM1 = STEMP RETURN * * End of DZSUM1 * END arpack-akloeckner-07/LAPACK/icmax1.f0000644000175000017500000000430006153460167016764 0ustar andreasandreas INTEGER FUNCTION ICMAX1( N, CX, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX CX( * ) * .. * * Purpose * ======= * * ICMAX1 finds the index of the element whose real part has maximum * absolute value. * * Based on ICAMAX from Level 1 BLAS. * The change is to use the 'genuine' absolute value. * * Contributed by Nick Higham for use with CLACON. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vector CX. * * CX (input) COMPLEX array, dimension (N) * The vector whose elements will be summed. * * INCX (input) INTEGER * The spacing between successive values of CX. INCX >= 1. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IX REAL SMAX COMPLEX ZDUM * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL * .. * .. Statement Functions .. REAL CABS1 * .. * .. Statement Function definitions .. * * NEXT LINE IS THE ONLY MODIFICATION. CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) * .. * .. Executable Statements .. * ICMAX1 = 0 IF( N.LT.1 ) $ RETURN ICMAX1 = 1 IF( N.EQ.1 ) $ RETURN IF( INCX.EQ.1 ) $ GO TO 30 * * CODE FOR INCREMENT NOT EQUAL TO 1 * IX = 1 SMAX = CABS1( CX( 1 ) ) IX = IX + INCX DO 20 I = 2, N IF( CABS1( CX( IX ) ).LE.SMAX ) $ GO TO 10 ICMAX1 = I SMAX = CABS1( CX( IX ) ) 10 CONTINUE IX = IX + INCX 20 CONTINUE RETURN * * CODE FOR INCREMENT EQUAL TO 1 * 30 CONTINUE SMAX = CABS1( CX( 1 ) ) DO 40 I = 2, N IF( CABS1( CX( I ) ).LE.SMAX ) $ GO TO 40 ICMAX1 = I SMAX = CABS1( CX( I ) ) 40 CONTINUE RETURN * * End of ICMAX1 * END arpack-akloeckner-07/LAPACK/ilaenv.f0000644000175000017500000003560306153460167017072 0ustar andreasandreas INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, $ N4 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER*( * ) NAME, OPTS INTEGER ISPEC, N1, N2, N3, N4 * .. * * Purpose * ======= * * ILAENV is called from the LAPACK routines to choose problem-dependent * parameters for the local environment. See ISPEC for a description of * the parameters. * * This version provides a set of parameters which should give good, * but not optimal, performance on many of the currently available * computers. Users are encouraged to modify this subroutine to set * the tuning parameters for their particular machine using the option * and problem size information in the arguments. * * This routine will not function correctly if it is converted to all * lower case. Converting it to all upper case is allowed. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be returned as the value of * ILAENV. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form.) * = 7: the number of processors * = 8: the crossover point for the multishift QR and QZ methods * for nonsymmetric eigenvalue problems. * * NAME (input) CHARACTER*(*) * The name of the calling subroutine, in either upper case or * lower case. * * OPTS (input) CHARACTER*(*) * The character options to the subroutine NAME, concatenated * into a single character string. For example, UPLO = 'U', * TRANS = 'T', and DIAG = 'N' for a triangular routine would * be specified as OPTS = 'UTN'. * * N1 (input) INTEGER * N2 (input) INTEGER * N3 (input) INTEGER * N4 (input) INTEGER * Problem dimensions for the subroutine NAME; these may not all * be required. * * (ILAENV) (output) INTEGER * >= 0: the value of the parameter specified by ISPEC * < 0: if ILAENV = -k, the k-th argument had an illegal value. * * Further Details * =============== * * The following conventions have been used when calling ILAENV from the * LAPACK routines: * 1) OPTS is a concatenation of all of the character options to * subroutine NAME, in the same order that they appear in the * argument list for NAME, even if they are not used in determining * the value of the parameter specified by ISPEC. * 2) The problem dimensions N1, N2, N3, N4 are specified in the order * that they appear in the argument list for NAME. N1 is used * first, N2 second, and so on, and unused problem dimensions are * passed a value of -1. * 3) The parameter value returned by ILAENV is checked for validity in * the calling subroutine. For example, ILAENV is used to retrieve * the optimal blocksize for STRTRI as follows: * * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) * IF( NB.LE.1 ) NB = MAX( 1, N ) * * ===================================================================== * * .. Local Scalars .. LOGICAL CNAME, SNAME CHARACTER*1 C1 CHARACTER*2 C2, C4 CHARACTER*3 C3 CHARACTER*6 SUBNAM INTEGER I, IC, IZ, NB, NBMIN, NX * .. * .. Intrinsic Functions .. INTRINSIC CHAR, ICHAR, INT, MIN, REAL * .. * .. Executable Statements .. * GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC * * Invalid value for ISPEC * ILAENV = -1 RETURN * 100 CONTINUE * * Convert NAME to upper case if the first character is lower case. * ILAENV = 1 SUBNAM = NAME IC = ICHAR( SUBNAM( 1:1 ) ) IZ = ICHAR( 'Z' ) IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN * * ASCII character set * IF( IC.GE.97 .AND. IC.LE.122 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 10 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.97 .AND. IC.LE.122 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 10 CONTINUE END IF * ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN * * EBCDIC character set * IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN SUBNAM( 1:1 ) = CHAR( IC+64 ) DO 20 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. $ ( IC.GE.162 .AND. IC.LE.169 ) ) $ SUBNAM( I:I ) = CHAR( IC+64 ) 20 CONTINUE END IF * ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN * * Prime machines: ASCII+128 * IF( IC.GE.225 .AND. IC.LE.250 ) THEN SUBNAM( 1:1 ) = CHAR( IC-32 ) DO 30 I = 2, 6 IC = ICHAR( SUBNAM( I:I ) ) IF( IC.GE.225 .AND. IC.LE.250 ) $ SUBNAM( I:I ) = CHAR( IC-32 ) 30 CONTINUE END IF END IF * C1 = SUBNAM( 1:1 ) SNAME = C1.EQ.'S' .OR. C1.EQ.'D' CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' IF( .NOT.( CNAME .OR. SNAME ) ) $ RETURN C2 = SUBNAM( 2:3 ) C3 = SUBNAM( 4:6 ) C4 = C3( 2:3 ) * GO TO ( 110, 200, 300 ) ISPEC * 110 CONTINUE * * ISPEC = 1: block size * * In these examples, separate code is provided for setting NB for * real and complex. We assume that NB will take the same value in * single or double precision. * NB = 1 * IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NB = 32 ELSE NB = 32 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NB = 1 ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRF' ) THEN NB = 64 ELSE IF( C3.EQ.'TRD' ) THEN NB = 1 ELSE IF( C3.EQ.'GST' ) THEN NB = 64 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NB = 32 END IF END IF ELSE IF( C2.EQ.'GB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N4.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'PB' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF ELSE IF( N2.LE.64 ) THEN NB = 1 ELSE NB = 32 END IF END IF END IF ELSE IF( C2.EQ.'TR' ) THEN IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( C2.EQ.'LA' ) THEN IF( C3.EQ.'UUM' ) THEN IF( SNAME ) THEN NB = 64 ELSE NB = 64 END IF END IF ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN IF( C3.EQ.'EBZ' ) THEN NB = 1 END IF END IF ILAENV = NB RETURN * 200 CONTINUE * * ISPEC = 2: minimum block size * NBMIN = 2 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF ELSE IF( C3.EQ.'TRI' ) THEN IF( SNAME ) THEN NBMIN = 2 ELSE NBMIN = 2 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN NBMIN = 8 ELSE NBMIN = 8 END IF ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NBMIN = 2 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF ELSE IF( C3( 1:1 ).EQ.'M' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NBMIN = 2 END IF END IF END IF ILAENV = NBMIN RETURN * 300 CONTINUE * * ISPEC = 3: crossover point * NX = 0 IF( C2.EQ.'GE' ) THEN IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. $ C3.EQ.'QLF' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'HRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF ELSE IF( C3.EQ.'BRD' ) THEN IF( SNAME ) THEN NX = 128 ELSE NX = 128 END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN NX = 1 END IF ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN IF( C3.EQ.'TRD' ) THEN NX = 1 END IF ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN IF( C3( 1:1 ).EQ.'G' ) THEN IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. $ C4.EQ.'BR' ) THEN NX = 128 END IF END IF END IF ILAENV = NX RETURN * 400 CONTINUE * * ISPEC = 4: number of shifts (used by xHSEQR) * ILAENV = 6 RETURN * 500 CONTINUE * * ISPEC = 5: minimum column dimension (not used) * ILAENV = 2 RETURN * 600 CONTINUE * * ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) * ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) RETURN * 700 CONTINUE * * ISPEC = 7: number of processors (not used) * ILAENV = 1 RETURN * 800 CONTINUE * * ISPEC = 8: crossover point for multishift (used by xHSEQR) * ILAENV = 50 RETURN * * End of ILAENV * END arpack-akloeckner-07/LAPACK/izmax1.f0000644000175000017500000000430306153460167017016 0ustar andreasandreas INTEGER FUNCTION IZMAX1( N, CX, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX*16 CX( * ) * .. * * Purpose * ======= * * IZMAX1 finds the index of the element whose real part has maximum * absolute value. * * Based on IZAMAX from Level 1 BLAS. * The change is to use the 'genuine' absolute value. * * Contributed by Nick Higham for use with ZLACON. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vector CX. * * CX (input) COMPLEX*16 array, dimension (N) * The vector whose elements will be summed. * * INCX (input) INTEGER * The spacing between successive values of CX. INCX >= 1. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IX DOUBLE PRECISION SMAX COMPLEX*16 ZDUM * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. * * NEXT LINE IS THE ONLY MODIFICATION. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) * .. * .. Executable Statements .. * IZMAX1 = 0 IF( N.LT.1 ) $ RETURN IZMAX1 = 1 IF( N.EQ.1 ) $ RETURN IF( INCX.EQ.1 ) $ GO TO 30 * * CODE FOR INCREMENT NOT EQUAL TO 1 * IX = 1 SMAX = CABS1( CX( 1 ) ) IX = IX + INCX DO 20 I = 2, N IF( CABS1( CX( IX ) ).LE.SMAX ) $ GO TO 10 IZMAX1 = I SMAX = CABS1( CX( IX ) ) 10 CONTINUE IX = IX + INCX 20 CONTINUE RETURN * * CODE FOR INCREMENT EQUAL TO 1 * 30 CONTINUE SMAX = CABS1( CX( 1 ) ) DO 40 I = 2, N IF( CABS1( CX( I ) ).LE.SMAX ) $ GO TO 40 IZMAX1 = I SMAX = CABS1( CX( I ) ) 40 CONTINUE RETURN * * End of IZMAX1 * END arpack-akloeckner-07/LAPACK/lsamen.f0000644000175000017500000000331706153460167017070 0ustar andreasandreas LOGICAL FUNCTION LSAMEN( N, CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER*( * ) CA, CB INTEGER N * .. * * Purpose * ======= * * LSAMEN tests if the first N letters of CA are the same as the * first N letters of CB, regardless of case. * LSAMEN returns .TRUE. if CA and CB are equivalent except for case * and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) * or LEN( CB ) is less than N. * * Arguments * ========= * * N (input) INTEGER * The number of characters in CA and CB to be compared. * * CA (input) CHARACTER*(*) * CB (input) CHARACTER*(*) * CA and CB specify two character strings of length at least N. * Only the first N characters of each string will be accessed. * * ===================================================================== * * .. Local Scalars .. INTEGER I * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC LEN * .. * .. Executable Statements .. * LSAMEN = .FALSE. IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N ) $ GO TO 20 * * Do for each character in the two strings. * DO 10 I = 1, N * * Test if the characters are equal using LSAME. * IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) ) $ GO TO 20 * 10 CONTINUE LSAMEN = .TRUE. * 20 CONTINUE RETURN * * End of LSAMEN * END arpack-akloeckner-07/LAPACK/scsum1.f0000644000175000017500000000346606153460167017031 0ustar andreasandreas REAL FUNCTION SCSUM1( N, CX, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX CX( * ) * .. * * Purpose * ======= * * SCSUM1 takes the sum of the absolute values of a complex * vector and returns a single precision result. * * Based on SCASUM from the Level 1 BLAS. * The change is to use the 'genuine' absolute value. * * Contributed by Nick Higham for use with CLACON. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vector CX. * * CX (input) COMPLEX array, dimension (N) * The vector whose elements will be summed. * * INCX (input) INTEGER * The spacing between successive values of CX. INCX > 0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, NINCX REAL STEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * SCSUM1 = 0.0E0 STEMP = 0.0E0 IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 ) $ GO TO 20 * * CODE FOR INCREMENT NOT EQUAL TO 1 * NINCX = N*INCX DO 10 I = 1, NINCX, INCX * * NEXT LINE MODIFIED. * STEMP = STEMP + ABS( CX( I ) ) 10 CONTINUE SCSUM1 = STEMP RETURN * * CODE FOR INCREMENT EQUAL TO 1 * 20 CONTINUE DO 30 I = 1, N * * NEXT LINE MODIFIED. * STEMP = STEMP + ABS( CX( I ) ) 30 CONTINUE SCSUM1 = STEMP RETURN * * End of SCSUM1 * END arpack-akloeckner-07/LAPACK/sgbtf2.f0000644000175000017500000001411206153460167016773 0ustar andreasandreas SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) REAL AB( LDAB, * ) * .. * * Purpose * ======= * * SGBTF2 computes an LU factorization of a real m-by-n band matrix A * using partial pivoting with row interchanges. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) REAL array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U, because of fill-in resulting from the row * interchanges. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J, JP, JU, KM, KV * .. * .. External Functions .. INTEGER ISAMAX EXTERNAL ISAMAX * .. * .. External Subroutines .. EXTERNAL SGER, SSCAL, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in. * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGBTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero. * DO 20 J = KU + 2, MIN( KV, N ) DO 10 I = KV - J + 2, KL AB( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * JU is the index of the last column affected by the current stage * of the factorization. * JU = 1 * DO 40 J = 1, MIN( M, N ) * * Set fill-in elements in column J+KV to zero. * IF( J+KV.LE.N ) THEN DO 30 I = 1, KL AB( I, J+KV ) = ZERO 30 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-J ) JP = ISAMAX( KM+1, AB( KV+1, J ), 1 ) IPIV( J ) = JP + J - 1 IF( AB( KV+JP, J ).NE.ZERO ) THEN JU = MAX( JU, MIN( J+KU+JP-1, N ) ) * * Apply interchange to columns J to JU. * IF( JP.NE.1 ) $ CALL SSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, $ AB( KV+1, J ), LDAB-1 ) * IF( KM.GT.0 ) THEN * * Compute multipliers. * CALL SSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) * * Update trailing submatrix within the band. * IF( JU.GT.J ) $ CALL SGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), $ LDAB-1 ) END IF ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = J END IF 40 CONTINUE RETURN * * End of SGBTF2 * END arpack-akloeckner-07/LAPACK/sgbtrf.f0000644000175000017500000003427206153460167017104 0ustar andreasandreas SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) REAL AB( LDAB, * ) * .. * * Purpose * ======= * * SGBTRF computes an LU factorization of a real m-by-n band matrix A * using partial pivoting with row interchanges. * * This is the blocked version of the algorithm, calling Level 3 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) REAL array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U because of fill-in resulting from the row interchanges. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) INTEGER NBMAX, LDWORK PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) * .. * .. Local Scalars .. INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, $ JU, K2, KM, KV, NB, NW REAL TEMP * .. * .. Local Arrays .. REAL WORK13( LDWORK, NBMAX ), $ WORK31( LDWORK, NBMAX ) * .. * .. External Functions .. INTEGER ILAENV, ISAMAX EXTERNAL ILAENV, ISAMAX * .. * .. External Subroutines .. EXTERNAL SCOPY, SGBTF2, SGEMM, SGER, SLASWP, SSCAL, $ SSWAP, STRSM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGBTRF', -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 = ILAENV( 1, 'SGBTRF', ' ', M, N, KL, KU ) * * The block size must not exceed the limit set by the size of the * local arrays WORK13 and WORK31. * NB = MIN( NB, NBMAX ) * IF( NB.LE.1 .OR. NB.GT.KL ) THEN * * Use unblocked code * CALL SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) ELSE * * Use blocked code * * Zero the superdiagonal elements of the work array WORK13 * DO 20 J = 1, NB DO 10 I = 1, J - 1 WORK13( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * Zero the subdiagonal elements of the work array WORK31 * DO 40 J = 1, NB DO 30 I = J + 1, NB WORK31( I, J ) = ZERO 30 CONTINUE 40 CONTINUE * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero * DO 60 J = KU + 2, MIN( KV, N ) DO 50 I = KV - J + 2, KL AB( I, J ) = ZERO 50 CONTINUE 60 CONTINUE * * JU is the index of the last column affected by the current * stage of the factorization * JU = 1 * DO 180 J = 1, MIN( M, N ), NB JB = MIN( NB, MIN( M, N )-J+1 ) * * The active part of the matrix is partitioned * * A11 A12 A13 * A21 A22 A23 * A31 A32 A33 * * Here A11, A21 and A31 denote the current block of JB columns * which is about to be factorized. The number of rows in the * partitioning are JB, I2, I3 respectively, and the numbers * of columns are JB, J2, J3. The superdiagonal elements of A13 * and the subdiagonal elements of A31 lie outside the band. * I2 = MIN( KL-JB, M-J-JB+1 ) I3 = MIN( JB, M-J-KL+1 ) * * J2 and J3 are computed after JU has been updated. * * Factorize the current block of JB columns * DO 80 JJ = J, J + JB - 1 * * Set fill-in elements in column JJ+KV to zero * IF( JJ+KV.LE.N ) THEN DO 70 I = 1, KL AB( I, JJ+KV ) = ZERO 70 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-JJ ) JP = ISAMAX( KM+1, AB( KV+1, JJ ), 1 ) IPIV( JJ ) = JP + JJ - J IF( AB( KV+JP, JJ ).NE.ZERO ) THEN JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) IF( JP.NE.1 ) THEN * * Apply interchange to columns J to J+JB-1 * IF( JP+JJ-1.LT.J+KL ) THEN * CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange affects columns J to JJ-1 of A31 * which are stored in the work array WORK31 * CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) CALL SSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, $ AB( KV+JP, JJ ), LDAB-1 ) END IF END IF * * Compute multipliers * CALL SSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), $ 1 ) * * Update trailing submatrix within the band and within * the current block. JM is the index of the last column * which needs to be updated. * JM = MIN( JU, J+JB-1 ) IF( JM.GT.JJ ) $ CALL SGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, $ AB( KV, JJ+1 ), LDAB-1, $ AB( KV+1, JJ+1 ), LDAB-1 ) ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = JJ END IF * * Copy current column of A31 into the work array WORK31 * NW = MIN( JJ-J+1, I3 ) IF( NW.GT.0 ) $ CALL SCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, $ WORK31( 1, JJ-J+1 ), 1 ) 80 CONTINUE IF( J+JB.LE.N ) THEN * * Apply the row interchanges to the other blocks. * J2 = MIN( JU-J+1, KV ) - JB J3 = MAX( 0, JU-J-KV+1 ) * * Use SLASWP to apply the row interchanges to A12, A22, and * A32. * CALL SLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, $ IPIV( J ), 1 ) * * Adjust the pivot indices. * DO 90 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 90 CONTINUE * * Apply the row interchanges to A13, A23, and A33 * columnwise. * K2 = J - 1 + JB + J2 DO 110 I = 1, J3 JJ = K2 + I DO 100 II = J + I - 1, J + JB - 1 IP = IPIV( II ) IF( IP.NE.II ) THEN TEMP = AB( KV+1+II-JJ, JJ ) AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) AB( KV+1+IP-JJ, JJ ) = TEMP END IF 100 CONTINUE 110 CONTINUE * * Update the relevant part of the trailing submatrix * IF( J2.GT.0 ) THEN * * Update A12 * CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1 ) * IF( I2.GT.0 ) THEN * * Update A22 * CALL SGEMM( 'No transpose', 'No transpose', I2, J2, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+1, J+JB ), LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A32 * CALL SGEMM( 'No transpose', 'No transpose', I3, J2, $ JB, -ONE, WORK31, LDWORK, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) END IF END IF * IF( J3.GT.0 ) THEN * * Copy the lower triangle of A13 into the work array * WORK13 * DO 130 JJ = 1, J3 DO 120 II = JJ, JB WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) 120 CONTINUE 130 CONTINUE * * Update A13 in the work array * CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, $ WORK13, LDWORK ) * IF( I2.GT.0 ) THEN * * Update A23 * CALL SGEMM( 'No transpose', 'No transpose', I2, J3, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), $ LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A33 * CALL SGEMM( 'No transpose', 'No transpose', I3, J3, $ JB, -ONE, WORK31, LDWORK, WORK13, $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) END IF * * Copy the lower triangle of A13 back into place * DO 150 JJ = 1, J3 DO 140 II = JJ, JB AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) 140 CONTINUE 150 CONTINUE END IF ELSE * * Adjust the pivot indices. * DO 160 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 160 CONTINUE END IF * * Partially undo the interchanges in the current block to * restore the upper triangular form of A31 and copy the upper * triangle of A31 back into place * DO 170 JJ = J + JB - 1, J, -1 JP = IPIV( JJ ) - JJ + 1 IF( JP.NE.1 ) THEN * * Apply interchange to columns J to JJ-1 * IF( JP+JJ-1.LT.J+KL ) THEN * * The interchange does not affect A31 * CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange does affect A31 * CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) END IF END IF * * Copy the current column of A31 back into place * NW = MIN( I3, JJ-J+1 ) IF( NW.GT.0 ) $ CALL SCOPY( NW, WORK31( 1, JJ-J+1 ), 1, $ AB( KV+KL+1-JJ+J, JJ ), 1 ) 170 CONTINUE 180 CONTINUE END IF * RETURN * * End of SGBTRF * END arpack-akloeckner-07/LAPACK/sgbtrs.f0000644000175000017500000001263006153460170017105 0ustar andreasandreas SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 2.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, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) REAL AB( LDAB, * ), B( LDB, * ) * .. * * Purpose * ======= * * SGBTRS solves a system of linear equations * A * X = B or A' * X = B * with a general band matrix A using the LU factorization computed * by SGBTRF. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * AB (input) REAL array, dimension (LDAB,N) * Details of the LU factorization of the band matrix A, as * computed by SGBTRF. U is stored as an upper triangular band * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and * the multipliers used during the factorization are stored in * rows KL+KU+2 to 2*KL+KU+1. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= N, row i of the matrix was * interchanged with row IPIV(i). * * B (input/output) REAL array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LNOTI, NOTRAN INTEGER I, J, KD, L, LM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SGEMV, SGER, SSWAP, STBSV, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. 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( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGBTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * KD = KU + KL + 1 LNOTI = KL.GT.0 * IF( NOTRAN ) THEN * * Solve A*X = B. * * Solve L*X = B, overwriting B with X. * * L is represented as a product of permutations and unit lower * triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), * where each transformation L(i) is a rank-one modification of * the identity matrix. * IF( LNOTI ) THEN DO 10 J = 1, N - 1 LM = MIN( KL, N-J ) L = IPIV( J ) IF( L.NE.J ) $ CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) CALL SGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), $ LDB, B( J+1, 1 ), LDB ) 10 CONTINUE END IF * DO 20 I = 1, NRHS * * Solve U*X = B, overwriting B with X. * CALL STBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, $ AB, LDAB, B( 1, I ), 1 ) 20 CONTINUE * ELSE * * Solve A'*X = B. * DO 30 I = 1, NRHS * * Solve U'*X = B, overwriting B with X. * CALL STBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, $ LDAB, B( 1, I ), 1 ) 30 CONTINUE * * Solve L'*X = B, overwriting B with X. * IF( LNOTI ) THEN DO 40 J = N - 1, 1, -1 LM = MIN( KL, N-J ) CALL SGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) L = IPIV( J ) IF( L.NE.J ) $ CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 40 CONTINUE END IF END IF RETURN * * End of SGBTRS * END arpack-akloeckner-07/LAPACK/sgeqr2.f0000644000175000017500000000643606153460170017013 0ustar andreasandreas SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER INFO, LDA, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * SGEQR2 computes a QR factorization of a real m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) REAL array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the orthogonal matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) REAL array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) REAL array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a real scalar, and v is a real vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, K REAL AII * .. * .. External Subroutines .. EXTERNAL SLARF, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * 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( 'SGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i) to A(i:m,i+1:n) from the left * AII = A( I, I ) A( I, I ) = ONE CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), $ A( I, I+1 ), LDA, WORK ) A( I, I ) = AII END IF 10 CONTINUE RETURN * * End of SGEQR2 * END arpack-akloeckner-07/LAPACK/sgttrf.f0000644000175000017500000001056406153460170017116 0ustar andreasandreas SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * * -- LAPACK routine (version 2.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, N * .. * .. Array Arguments .. INTEGER IPIV( * ) REAL D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * SGTTRF computes an LU factorization of a real tridiagonal matrix A * using elimination with partial pivoting and row interchanges. * * The factorization has the form * A = L * U * where L is a product of permutation and unit lower bidiagonal * matrices and U is upper triangular with nonzeros in only the main * diagonal and first two superdiagonals. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * DL (input/output) REAL array, dimension (N-1) * On entry, DL must contain the (n-1) subdiagonal elements of * A. * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) REAL array, dimension (N) * On entry, D must contain the diagonal elements of A. * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) REAL array, dimension (N-1) * On entry, DU must contain the (n-1) superdiagonal elements * of A. * On exit, DU is overwritten by the (n-1) elements of the first * superdiagonal of U. * * DU2 (output) REAL array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the * second superdiagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * 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. * * ===================================================================== * * .. Local Scalars .. INTEGER I REAL FACT, TEMP * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'SGTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Initialize IPIV(i) = i * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE * DO 20 I = 1, N - 1 IF( DL( I ).EQ.ZERO ) THEN * * Subdiagonal is zero, no elimination is required. * IF( D( I ).EQ.ZERO .AND. INFO.EQ.0 ) $ INFO = I IF( I.LT.N-1 ) $ DU2( I ) = ZERO ELSE IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * FACT = DL( I ) / D( I ) DL( I ) = FACT D( I+1 ) = D( I+1 ) - FACT*DU( I ) IF( I.LT.N-1 ) $ DU2( I ) = ZERO ELSE * * Interchange rows I and I+1, eliminate DL(I) * FACT = D( I ) / DL( I ) D( I ) = DL( I ) DL( I ) = FACT TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) IF( I.LT.N-1 ) THEN DU2( I ) = DU( I+1 ) DU( I+1 ) = -FACT*DU( I+1 ) END IF IPIV( I ) = IPIV( I ) + 1 END IF 20 CONTINUE IF( D( N ).EQ.ZERO .AND. INFO.EQ.0 ) THEN INFO = N RETURN END IF * RETURN * * End of SGTTRF * END arpack-akloeckner-07/LAPACK/sgttrs.f0000644000175000017500000001216706153460170017134 0ustar andreasandreas SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 2.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, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * SGTTRS solves one of the systems of equations * A*X = B or A'*X = B, * with a tridiagonal matrix A using the LU factorization computed * by SGTTRF. * * Arguments * ========= * * TRANS (input) CHARACTER * 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. * * DL (input) REAL array, dimension (N-1) * The (n-1) multipliers that define the matrix L from the * LU factorization of A. * * D (input) REAL array, dimension (N) * The n diagonal elements of the upper triangular matrix U from * the LU factorization of A. * * DU (input) REAL array, dimension (N-1) * The (n-1) elements of the first superdiagonal of U. * * DU2 (input) REAL array, dimension (N-2) * The (n-2) elements of the second superdiagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * B (input/output) REAL array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, B is overwritten by 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 * * ===================================================================== * * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, J REAL TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * 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( LDB.LT.MAX( N, 1 ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SGTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A*X = B using the LU factorization of A, * overwriting each right hand side vector with its solution. * DO 30 J = 1, NRHS * * Solve L*x = b. * DO 10 I = 1, N - 1 IF( IPIV( I ).EQ.I ) THEN B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) ELSE TEMP = B( I, J ) B( I, J ) = B( I+1, J ) B( I+1, J ) = TEMP - DL( I )*B( I, J ) END IF 10 CONTINUE * * Solve U*x = b. * B( N, J ) = B( N, J ) / D( N ) IF( N.GT.1 ) $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / $ D( N-1 ) DO 20 I = N - 2, 1, -1 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* $ B( I+2, J ) ) / D( I ) 20 CONTINUE 30 CONTINUE ELSE * * Solve A' * X = B. * DO 60 J = 1, NRHS * * Solve U'*x = b. * B( 1, J ) = B( 1, J ) / D( 1 ) IF( N.GT.1 ) $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) DO 40 I = 3, N B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* $ B( I-2, J ) ) / D( I ) 40 CONTINUE * * Solve L'*x = b. * DO 50 I = N - 1, 1, -1 IF( IPIV( I ).EQ.I ) THEN B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) ELSE TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - DL( I )*TEMP B( I, J ) = TEMP END IF 50 CONTINUE 60 CONTINUE END IF * * End of SGTTRS * END arpack-akloeckner-07/LAPACK/slabad.f0000644000175000017500000000346606153460170017036 0ustar andreasandreas SUBROUTINE SLABAD( SMALL, LARGE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. REAL LARGE, SMALL * .. * * Purpose * ======= * * SLABAD takes as input the values computed by SLAMCH for underflow and * overflow, and returns the square root of each of these values if the * log of LARGE is sufficiently large. This subroutine is intended to * identify machines with a large exponent range, such as the Crays, and * redefine the underflow and overflow limits to be the square roots of * the values computed by SLAMCH. This subroutine is needed because * SLAMCH does not compensate for poor arithmetic in the upper half of * the exponent range, as is found on a Cray. * * Arguments * ========= * * SMALL (input/output) REAL * On entry, the underflow threshold as computed by SLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of SMALL, otherwise unchanged. * * LARGE (input/output) REAL * On entry, the overflow threshold as computed by SLAMCH. * On exit, if LOG10(LARGE) is sufficiently large, the square * root of LARGE, otherwise unchanged. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC LOG10, SQRT * .. * .. Executable Statements .. * * If it looks like we're on a Cray, take the square root of * SMALL and LARGE to avoid overflow and underflow problems. * IF( LOG10( LARGE ).GT.2000. ) THEN SMALL = SQRT( SMALL ) LARGE = SQRT( LARGE ) END IF * RETURN * * End of SLABAD * END arpack-akloeckner-07/LAPACK/slacon.f0000644000175000017500000001214706153460170017063 0ustar andreasandreas SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER KASE, N REAL EST * .. * .. Array Arguments .. INTEGER ISGN( * ) REAL V( * ), X( * ) * .. * * Purpose * ======= * * SLACON estimates the 1-norm of a square, real matrix A. * Reverse communication is used for evaluating matrix-vector products. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix. N >= 1. * * V (workspace) REAL array, dimension (N) * On the final return, V = A*W, where EST = norm(V)/norm(W) * (W is not returned). * * X (input/output) REAL array, dimension (N) * On an intermediate return, X should be overwritten by * A * X, if KASE=1, * A' * X, if KASE=2, * and SLACON must be re-called with all the other parameters * unchanged. * * ISGN (workspace) INTEGER array, dimension (N) * * EST (output) REAL * An estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to SLACON, KASE should be 0. * On an intermediate return, KASE will be 1 or 2, indicating * whether X should be overwritten by A * X or A' * X. * On the final return from SLACON, KASE will again be 0. * * Further Details * ======= ======= * * Contributed by Nick Higham, University of Manchester. * Originally named SONEST, dated March 16, 1988. * * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of * a real or complex matrix, with applications to condition estimation", * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) REAL ZERO, ONE, TWO PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP REAL ALTSGN, ESTOLD, TEMP * .. * .. External Functions .. INTEGER ISAMAX REAL SASUM EXTERNAL ISAMAX, SASUM * .. * .. External Subroutines .. EXTERNAL SCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, NINT, REAL, SIGN * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = ONE / REAL( N ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 110, 140 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 150 END IF EST = SASUM( N, X, 1 ) * DO 30 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 40 CONTINUE J = ISAMAX( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = ZERO 60 CONTINUE X( J ) = ONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL SCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = SASUM( N, V, 1 ) DO 80 I = 1, N IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) $ GO TO 90 80 CONTINUE * REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 * 90 CONTINUE * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 120 * DO 100 I = 1, N X( I ) = SIGN( ONE, X( I ) ) ISGN( I ) = NINT( X( I ) ) 100 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. * 110 CONTINUE JLAST = J J = ISAMAX( N, X, 1 ) IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 120 CONTINUE ALTSGN = ONE DO 130 I = 1, N X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) ) ALTSGN = -ALTSGN 130 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 140 CONTINUE TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL SCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 150 CONTINUE KASE = 0 RETURN * * End of SLACON * END arpack-akloeckner-07/LAPACK/slacpy.f0000644000175000017500000000457606153460170017106 0ustar andreasandreas SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 2.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 LDA, LDB, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * SLACPY copies all or part of a two-dimensional matrix A to another * matrix B. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be copied to B. * = 'U': Upper triangular part * = 'L': Lower triangular part * Otherwise: All of the matrix A * * 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) REAL array, dimension (LDA,N) * The m by n matrix A. If UPLO = 'U', only the upper triangle * or trapezoid is accessed; if UPLO = 'L', only the lower * triangle or trapezoid is accessed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (output) REAL array, dimension (LDB,N) * On exit, B = A in the locations specified by UPLO. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF RETURN * * End of SLACPY * END arpack-akloeckner-07/LAPACK/sladiv.f0000644000175000017500000000271506153460170017066 0ustar andreasandreas SUBROUTINE SLADIV( A, B, C, D, P, Q ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. REAL A, B, C, D, P, Q * .. * * Purpose * ======= * * SLADIV performs complex division in real arithmetic * * a + i*b * p + i*q = --------- * c + i*d * * The algorithm is due to Robert L. Smith and can be found * in D. Knuth, The art of Computer Programming, Vol.2, p.195 * * Arguments * ========= * * A (input) REAL * B (input) REAL * C (input) REAL * D (input) REAL * The scalars a, b, c, and d in the above expression. * * P (output) REAL * Q (output) REAL * The scalars p and q in the above expression. * * ===================================================================== * * .. Local Scalars .. REAL E, F * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( ABS( D ).LT.ABS( C ) ) THEN E = D / C F = C + D*E P = ( A+B*E ) / F Q = ( B-A*E ) / F ELSE E = C / D F = D + C*E P = ( B+A*E ) / F Q = ( -A+B*E ) / F END IF * RETURN * * End of SLADIV * END arpack-akloeckner-07/LAPACK/slae2.f0000644000175000017500000000633406153460171016614 0ustar andreasandreas SUBROUTINE SLAE2( A, B, C, RT1, RT2 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. REAL A, B, C, RT1, RT2 * .. * * Purpose * ======= * * SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix * [ A B ] * [ B C ]. * On return, RT1 is the eigenvalue of larger absolute value, and RT2 * is the eigenvalue of smaller absolute value. * * Arguments * ========= * * A (input) REAL * The (1,1) element of the 2-by-2 matrix. * * B (input) REAL * The (1,2) and (2,1) elements of the 2-by-2 matrix. * * C (input) REAL * The (2,2) element of the 2-by-2 matrix. * * RT1 (output) REAL * The eigenvalue of larger absolute value. * * RT2 (output) REAL * The eigenvalue of smaller absolute value. * * Further Details * =============== * * RT1 is accurate to a few ulps barring over/underflow. * * RT2 may be inaccurate if there is massive cancellation in the * determinant A*C-B*B; higher precision or correctly rounded or * correctly truncated arithmetic would be needed to compute RT2 * accurately in all cases. * * Overflow is possible only if RT1 is within a factor of 5 of overflow. * Underflow is harmless if the input data is 0 or exceeds * underflow_threshold / macheps. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL HALF PARAMETER ( HALF = 0.5E0 ) * .. * .. Local Scalars .. REAL AB, ACMN, ACMX, ADF, DF, RT, SM, TB * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT END IF RETURN * * End of SLAE2 * END arpack-akloeckner-07/LAPACK/slaev2.f0000644000175000017500000001063106153460171016775 0ustar andreasandreas SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. REAL A, B, C, CS1, RT1, RT2, SN1 * .. * * Purpose * ======= * * SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix * [ A B ] * [ B C ]. * On return, RT1 is the eigenvalue of larger absolute value, RT2 is the * eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right * eigenvector for RT1, giving the decomposition * * [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] * [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. * * Arguments * ========= * * A (input) REAL * The (1,1) element of the 2-by-2 matrix. * * B (input) REAL * The (1,2) element and the conjugate of the (2,1) element of * the 2-by-2 matrix. * * C (input) REAL * The (2,2) element of the 2-by-2 matrix. * * RT1 (output) REAL * The eigenvalue of larger absolute value. * * RT2 (output) REAL * The eigenvalue of smaller absolute value. * * CS1 (output) REAL * SN1 (output) REAL * The vector (CS1, SN1) is a unit right eigenvector for RT1. * * Further Details * =============== * * RT1 is accurate to a few ulps barring over/underflow. * * RT2 may be inaccurate if there is massive cancellation in the * determinant A*C-B*B; higher precision or correctly rounded or * correctly truncated arithmetic would be needed to compute RT2 * accurately in all cases. * * CS1 and SN1 are accurate to a few ulps barring over/underflow. * * Overflow is possible only if RT1 is within a factor of 5 of overflow. * Underflow is harmless if the input data is 0 or exceeds * underflow_threshold / macheps. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL HALF PARAMETER ( HALF = 0.5E0 ) * .. * .. Local Scalars .. INTEGER SGN1, SGN2 REAL AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, $ TB, TN * .. * .. Intrinsic Functions .. INTRINSIC ABS, SQRT * .. * .. Executable Statements .. * * Compute the eigenvalues * SM = A + C DF = A - C ADF = ABS( DF ) TB = B + B AB = ABS( TB ) IF( ABS( A ).GT.ABS( C ) ) THEN ACMX = A ACMN = C ELSE ACMX = C ACMN = A END IF IF( ADF.GT.AB ) THEN RT = ADF*SQRT( ONE+( AB / ADF )**2 ) ELSE IF( ADF.LT.AB ) THEN RT = AB*SQRT( ONE+( ADF / AB )**2 ) ELSE * * Includes case AB=ADF=0 * RT = AB*SQRT( TWO ) END IF IF( SM.LT.ZERO ) THEN RT1 = HALF*( SM-RT ) SGN1 = -1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE IF( SM.GT.ZERO ) THEN RT1 = HALF*( SM+RT ) SGN1 = 1 * * Order of execution important. * To get fully accurate smaller eigenvalue, * next line needs to be executed in higher precision. * RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B ELSE * * Includes case RT1 = RT2 = 0 * RT1 = HALF*RT RT2 = -HALF*RT SGN1 = 1 END IF * * Compute the eigenvector * IF( DF.GE.ZERO ) THEN CS = DF + RT SGN2 = 1 ELSE CS = DF - RT SGN2 = -1 END IF ACS = ABS( CS ) IF( ACS.GT.AB ) THEN CT = -TB / CS SN1 = ONE / SQRT( ONE+CT*CT ) CS1 = CT*SN1 ELSE IF( AB.EQ.ZERO ) THEN CS1 = ONE SN1 = ZERO ELSE TN = -CS / TB CS1 = ONE / SQRT( ONE+TN*TN ) SN1 = TN*CS1 END IF END IF IF( SGN1.EQ.SGN2 ) THEN TN = CS1 CS1 = -SN1 SN1 = TN END IF RETURN * * End of SLAEV2 * END arpack-akloeckner-07/LAPACK/slarf.f0000644000175000017500000000577606153460173016730 0ustar andreasandreas SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N REAL TAU * .. * .. Array Arguments .. REAL C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * SLARF applies a real elementary reflector H to a real m by n matrix * C, from either the left or the right. H is represented in the form * * H = I - tau * v * v' * * where tau is a real scalar and v is a real vector. * * If tau = 0, then H is taken to be the unit matrix. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) REAL array, dimension * (1 + (M-1)*abs(INCV)) if SIDE = 'L' * or (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of H. V is not used if * TAU = 0. * * INCV (input) INTEGER * The increment between elements of v. INCV <> 0. * * TAU (input) REAL * The value tau in the representation of H. * * C (input/output) REAL array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) REAL array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. External Subroutines .. EXTERNAL SGEMV, SGER * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w := C' * v * CALL SGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, $ WORK, 1 ) * * C := C - v * w' * CALL SGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w := C * v * CALL SGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - w * v' * CALL SGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of SLARF * END arpack-akloeckner-07/LAPACK/slaexc.f0000644000175000017500000002477406153460171017075 0ustar andreasandreas SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. LOGICAL WANTQ INTEGER INFO, J1, LDQ, LDT, N, N1, N2 * .. * .. Array Arguments .. REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * Purpose * ======= * * SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in * an upper quasi-triangular matrix T by an orthogonal similarity * transformation. * * T must be in Schur canonical form, that is, block upper triangular * with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block * has its diagonal elemnts equal and its off-diagonal elements of * opposite sign. * * Arguments * ========= * * WANTQ (input) LOGICAL * = .TRUE. : accumulate the transformation in the matrix Q; * = .FALSE.: do not accumulate the transformation. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) REAL array, dimension (LDT,N) * On entry, the upper quasi-triangular matrix T, in Schur * canonical form. * On exit, the updated matrix T, again in Schur canonical form. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) REAL array, dimension (LDQ,N) * On entry, if WANTQ is .TRUE., the orthogonal matrix Q. * On exit, if WANTQ is .TRUE., the updated matrix Q. * If WANTQ is .FALSE., Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. * * J1 (input) INTEGER * The index of the first row of the first block T11. * * N1 (input) INTEGER * The order of the first block T11. N1 = 0, 1 or 2. * * N2 (input) INTEGER * The order of the second block T22. N2 = 0, 1 or 2. * * WORK (workspace) REAL array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * = 1: the transformed matrix T would be too far from Schur * form; the blocks are not swapped and T and Q are * unchanged. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) REAL TEN PARAMETER ( TEN = 1.0E+1 ) INTEGER LDD, LDX PARAMETER ( LDD = 4, LDX = 2 ) * .. * .. Local Scalars .. INTEGER IERR, J2, J3, J4, K, ND REAL CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22, $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, $ WR1, WR2, XNORM * .. * .. Local Arrays .. REAL D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ), $ X( LDX, 2 ) * .. * .. External Functions .. REAL SLAMCH, SLANGE EXTERNAL SLAMCH, SLANGE * .. * .. External Subroutines .. EXTERNAL SLACPY, SLANV2, SLARFG, SLARFX, SLARTG, SLASY2, $ SROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN IF( J1+N1.GT.N ) $ RETURN * J2 = J1 + 1 J3 = J1 + 2 J4 = J1 + 3 * IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN * * Swap two 1-by-1 blocks. * T11 = T( J1, J1 ) T22 = T( J2, J2 ) * * Determine the transformation to perform the interchange. * CALL SLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( J3.LE.N ) $ CALL SROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS, $ SN ) CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) * T( J1, J1 ) = T22 T( J2, J2 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * ELSE * * Swapping involves at least one 2-by-2 block. * * Copy the diagonal block of order N1+N2 to the local array D * and compute its norm. * ND = N1 + N2 CALL SLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD ) DNORM = SLANGE( 'Max', ND, ND, D, LDD, WORK ) * * Compute machine-dependent threshold for test for accepting * swap. * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) * * Solve T11*X - X*T22 = scale*T12 for X. * CALL SLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X, $ LDX, XNORM, IERR ) * * Swap the adjacent diagonal blocks. * K = N1 + N1 + N2 - 3 GO TO ( 10, 20, 30 )K * 10 CONTINUE * * N1 = 1, N2 = 2: generate elementary reflector H so that: * * ( scale, X11, X12 ) H = ( 0, 0, * ) * U( 1 ) = SCALE U( 2 ) = X( 1, 1 ) U( 3 ) = X( 1, 2 ) CALL SLARFG( 3, U( 3 ), U, 1, TAU ) U( 3 ) = ONE T11 = T( J1, J1 ) * * Perform swap provisionally on diagonal block in D. * CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL SLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3, $ 3 )-T11 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL SLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK ) CALL SLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J3, J3 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL SLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 20 CONTINUE * * N1 = 2, N2 = 1: generate elementary reflector H so that: * * H ( -X11 ) = ( * ) * ( -X21 ) = ( 0 ) * ( scale ) = ( 0 ) * U( 1 ) = -X( 1, 1 ) U( 2 ) = -X( 2, 1 ) U( 3 ) = SCALE CALL SLARFG( 3, U( 1 ), U( 2 ), 1, TAU ) U( 1 ) = ONE T33 = T( J3, J3 ) * * Perform swap provisionally on diagonal block in D. * CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK ) CALL SLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1, $ 1 )-T33 ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL SLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK ) CALL SLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK ) * T( J1, J1 ) = T33 T( J2, J1 ) = ZERO T( J3, J1 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL SLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK ) END IF GO TO 40 * 30 CONTINUE * * N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so * that: * * H(2) H(1) ( -X11 -X12 ) = ( * * ) * ( -X21 -X22 ) ( 0 * ) * ( scale 0 ) ( 0 0 ) * ( 0 scale ) ( 0 0 ) * U1( 1 ) = -X( 1, 1 ) U1( 2 ) = -X( 2, 1 ) U1( 3 ) = SCALE CALL SLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 ) U1( 1 ) = ONE * TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) ) U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 ) U2( 2 ) = -TEMP*U1( 3 ) U2( 3 ) = SCALE CALL SLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 ) U2( 1 ) = ONE * * Perform swap provisionally on diagonal block in D. * CALL SLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK ) CALL SLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK ) CALL SLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK ) CALL SLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK ) * * Test whether to reject swap. * IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ), $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50 * * Accept swap: apply transformation to the entire matrix T. * CALL SLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK ) CALL SLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK ) CALL SLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK ) CALL SLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK ) * T( J3, J1 ) = ZERO T( J3, J2 ) = ZERO T( J4, J1 ) = ZERO T( J4, J2 ) = ZERO * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL SLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK ) CALL SLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK ) END IF * 40 CONTINUE * IF( N2.EQ.2 ) THEN * * Standardize new 2-by-2 block T11 * CALL SLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ), $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN ) CALL SROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT, $ CS, SN ) CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN ) IF( WANTQ ) $ CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN ) END IF * IF( N1.EQ.2 ) THEN * * Standardize new 2-by-2 block T22 * J3 = J1 + N2 J4 = J3 + 1 CALL SLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ), $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN ) IF( J3+2.LE.N ) $ CALL SROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ), $ LDT, CS, SN ) CALL SROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN ) IF( WANTQ ) $ CALL SROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN ) END IF * END IF RETURN * * Exit with INFO = 1 if swap was rejected. * 50 INFO = 1 RETURN * * End of SLAEXC * END arpack-akloeckner-07/LAPACK/slagtm.f0000644000175000017500000001372006153460171017072 0ustar andreasandreas SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER TRANS INTEGER LDB, LDX, N, NRHS REAL ALPHA, BETA * .. * .. Array Arguments .. REAL B( LDB, * ), D( * ), DL( * ), DU( * ), $ X( LDX, * ) * .. * * Purpose * ======= * * SLAGTM performs a matrix-vector product of the form * * B := alpha * A * X + beta * B * * where A is a tridiagonal matrix of order N, B and X are N by NRHS * matrices, and alpha and beta are real scalars, each of which may be * 0., 1., or -1. * * Arguments * ========= * * TRANS (input) CHARACTER * Specifies the operation applied to A. * = 'N': No transpose, B := alpha * A * X + beta * B * = 'T': Transpose, B := alpha * A'* X + beta * B * = 'C': 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 matrices X and B. * * ALPHA (input) REAL * The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, * it is assumed to be 0. * * DL (input) REAL array, dimension (N-1) * The (n-1) sub-diagonal elements of T. * * D (input) REAL array, dimension (N) * The diagonal elements of T. * * DU (input) REAL array, dimension (N-1) * The (n-1) super-diagonal elements of T. * * X (input) REAL array, dimension (LDX,NRHS) * The N by NRHS matrix X. * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(N,1). * * BETA (input) REAL * The scalar beta. BETA must be 0., 1., or -1.; otherwise, * it is assumed to be 1. * * B (input/output) REAL array, dimension (LDB,NRHS) * On entry, the N by NRHS matrix B. * On exit, B is overwritten by the matrix expression * B := alpha * A * X + beta * B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(N,1). * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( N.EQ.0 ) $ RETURN * * Multiply B by BETA if BETA.NE.1. * IF( BETA.EQ.ZERO ) THEN DO 20 J = 1, NRHS DO 10 I = 1, N B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE IF( BETA.EQ.-ONE ) THEN DO 40 J = 1, NRHS DO 30 I = 1, N B( I, J ) = -B( I, J ) 30 CONTINUE 40 CONTINUE END IF * IF( ALPHA.EQ.ONE ) THEN IF( LSAME( TRANS, 'N' ) ) THEN * * Compute B := B + A*X * DO 60 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + $ DU( 1 )*X( 2, J ) B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) + $ D( N )*X( N, J ) DO 50 I = 2, N - 1 B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) + $ D( I )*X( I, J ) + DU( I )*X( I+1, J ) 50 CONTINUE END IF 60 CONTINUE ELSE * * Compute B := B + A'*X * DO 80 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + $ DL( 1 )*X( 2, J ) B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) + $ D( N )*X( N, J ) DO 70 I = 2, N - 1 B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) + $ D( I )*X( I, J ) + DL( I )*X( I+1, J ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( ALPHA.EQ.-ONE ) THEN IF( LSAME( TRANS, 'N' ) ) THEN * * Compute B := B - A*X * DO 100 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - $ DU( 1 )*X( 2, J ) B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) - $ D( N )*X( N, J ) DO 90 I = 2, N - 1 B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) - $ D( I )*X( I, J ) - DU( I )*X( I+1, J ) 90 CONTINUE END IF 100 CONTINUE ELSE * * Compute B := B - A'*X * DO 120 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - $ DL( 1 )*X( 2, J ) B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) - $ D( N )*X( N, J ) DO 110 I = 2, N - 1 B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) - $ D( I )*X( I, J ) - DL( I )*X( I+1, J ) 110 CONTINUE END IF 120 CONTINUE END IF END IF RETURN * * End of SLAGTM * END arpack-akloeckner-07/LAPACK/slahqr.f0000644000175000017500000003226606153460171017103 0ustar andreasandreas SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL WANTT, WANTZ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * SLAHQR is an auxiliary routine called by SHSEQR to update the * eigenvalues and Schur decomposition already computed by SHSEQR, by * dealing with the Hessenberg submatrix in rows and columns ILO to IHI. * * Arguments * ========= * * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * * N (input) INTEGER * The order of the matrix H. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper quasi-triangular in * rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless * ILO = 1). SLAHQR works primarily with the Hessenberg * submatrix in rows and columns ILO to IHI, but applies * transformations to all of H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * * H (input/output) REAL array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if WANTT is .TRUE., H is upper quasi-triangular in * rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in * standard form. If WANTT is .FALSE., the contents of H are * unspecified on exit. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * * WR (output) REAL array, dimension (N) * WI (output) REAL array, dimension (N) * The real and imaginary parts, respectively, of the computed * eigenvalues ILO to IHI are stored in the corresponding * elements of WR and WI. If two eigenvalues are computed as a * complex conjugate pair, they are stored in consecutive * elements of WR and WI, say the i-th and (i+1)th, with * WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the * eigenvalues are stored in the same order as on the diagonal * of the Schur form returned in H, with WR(i) = H(i,i), and, if * H(i:i+1,i:i+1) is a 2-by-2 diagonal block, * WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * * Z (input/output) REAL array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by SHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * > 0: SLAHQR failed to compute all the eigenvalues ILO to IHI * in a total of 30*(IHI-ILO+1) iterations; if INFO = i, * elements i+1:ihi of WR and WI contain those eigenvalues * which have been successfully computed. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) REAL DAT1, DAT2 PARAMETER ( DAT1 = 0.75E+0, DAT2 = -0.4375E+0 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NR, NZ REAL CS, H00, H10, H11, H12, H21, H22, H33, H33S, $ H43H34, H44, H44S, OVFL, S, SMLNUM, SN, SUM, $ T1, T2, T3, TST1, ULP, UNFL, V1, V2, V3 * .. * .. Local Arrays .. REAL V( 3 ), WORK( 1 ) * .. * .. External Functions .. REAL SLAMCH, SLANHS EXTERNAL SLAMCH, SLANHS * .. * .. External Subroutines .. EXTERNAL SCOPY, SLABAD, SLANV2, SLARFG, SROT * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN WR( ILO ) = H( ILO, ILO ) WI( ILO ) = ZERO RETURN END IF * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * If norm(H) <= sqrt(OVFL), overflow should not occur. * UNFL = SLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL SLABAD( UNFL, OVFL ) ULP = SLAMCH( 'Precision' ) SMLNUM = UNFL*( NH / ULP ) * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITN is the total number of QR iterations allowed. * ITN = 30*NH * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1 or 2. Each iteration of the loop works * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 10 CONTINUE L = ILO IF( I.LT.ILO ) $ GO TO 150 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 or 2 splits off at the bottom because a * subdiagonal element has become negligible. * DO 130 ITS = 0, ITN * * Look for a single small subdiagonal element. * DO 20 K = I, L + 1, -1 TST1 = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) ) IF( TST1.EQ.ZERO ) $ TST1 = SLANHS( '1', I-L+1, H( L, L ), LDH, WORK ) IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) ) $ GO TO 30 20 CONTINUE 30 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 or 2 has split off. * IF( L.GE.I-1 ) $ GO TO 140 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN * * Exceptional shift. * S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) H44 = DAT1*S H33 = H44 H43H34 = DAT2*S*S ELSE * * Prepare to use Wilkinson's double shift * H44 = H( I, I ) H33 = H( I-1, I-1 ) H43H34 = H( I, I-1 )*H( I-1, I ) END IF * * Look for two consecutive small subdiagonal elements. * DO 40 M = I - 2, L, -1 * * Determine the effect of starting the double-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. * H11 = H( M, M ) H22 = H( M+1, M+1 ) H21 = H( M+1, M ) H12 = H( M, M+1 ) H44S = H44 - H11 H33S = H33 - H11 V1 = ( H33S*H44S-H43H34 ) / H21 + H12 V2 = H22 - H11 - H33S - H44S V3 = H( M+2, M+1 ) S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) V1 = V1 / S V2 = V2 / S V3 = V3 / S V( 1 ) = V1 V( 2 ) = V2 V( 3 ) = V3 IF( M.EQ.L ) $ GO TO 50 H00 = H( M-1, M-1 ) H10 = H( M, M-1 ) TST1 = ABS( V1 )*( ABS( H00 )+ABS( H11 )+ABS( H22 ) ) IF( ABS( H10 )*( ABS( V2 )+ABS( V3 ) ).LE.ULP*TST1 ) $ GO TO 50 40 CONTINUE 50 CONTINUE * * Double-shift QR step * DO 120 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. NR is the order of G. * NR = MIN( 3, I-K+1 ) IF( K.GT.M ) $ CALL SCOPY( NR, H( K, K-1 ), 1, V, 1 ) CALL SLARFG( NR, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO IF( K.LT.I-1 ) $ H( K+2, K-1 ) = ZERO ELSE IF( M.GT.L ) THEN H( K, K-1 ) = -H( K, K-1 ) END IF V2 = V( 2 ) T2 = T1*V2 IF( NR.EQ.3 ) THEN V3 = V( 3 ) T3 = T1*V3 * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 60 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 H( K+2, J ) = H( K+2, J ) - SUM*T3 60 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 70 J = I1, MIN( K+3, I ) SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 H( J, K+2 ) = H( J, K+2 ) - SUM*T3 70 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 80 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3 80 CONTINUE END IF ELSE IF( NR.EQ.2 ) THEN * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 90 J = K, I2 SUM = H( K, J ) + V2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM*T1 H( K+1, J ) = H( K+1, J ) - SUM*T2 90 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+3,I). * DO 100 J = I1, I SUM = H( J, K ) + V2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM*T1 H( J, K+1 ) = H( J, K+1 ) - SUM*T2 100 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 110 J = ILOZ, IHIZ SUM = Z( J, K ) + V2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM*T1 Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2 110 CONTINUE END IF END IF 120 CONTINUE * 130 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 140 CONTINUE * IF( L.EQ.I ) THEN * * H(I,I-1) is negligible: one eigenvalue has converged. * WR( I ) = H( I, I ) WI( I ) = ZERO ELSE IF( L.EQ.I-1 ) THEN * * H(I-1,I-2) is negligible: a pair of eigenvalues have converged. * * Transform the 2-by-2 submatrix to standard Schur form, * and compute and store the eigenvalues. * CALL SLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ), $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ), $ CS, SN ) * IF( WANTT ) THEN * * Apply the transformation to the rest of H. * IF( I2.GT.I ) $ CALL SROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH, $ CS, SN ) CALL SROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN ) END IF IF( WANTZ ) THEN * * Apply the transformation to Z. * CALL SROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN ) END IF END IF * * Decrement number of remaining iterations, and return to start of * the main loop with new value of I. * ITN = ITN - ITS I = L - 1 GO TO 10 * 150 CONTINUE RETURN * * End of SLAHQR * END arpack-akloeckner-07/LAPACK/slaln2.f0000644000175000017500000004017706153460171017004 0ustar andreasandreas SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL LTRANS INTEGER INFO, LDA, LDB, LDX, NA, NW REAL CA, D1, D2, SCALE, SMIN, WI, WR, XNORM * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), X( LDX, * ) * .. * * Purpose * ======= * * SLALN2 solves a system of the form (ca A - w D ) X = s B * or (ca A' - w D) X = s B with possible scaling ("s") and * perturbation of A. (A' means A-transpose.) * * A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA * real diagonal matrix, w is a real or complex value, and X and B are * NA x 1 matrices -- real if w is real, complex if w is complex. NA * may be 1 or 2. * * If w is complex, X and B are represented as NA x 2 matrices, * the first column of each being the real part and the second * being the imaginary part. * * "s" is a scaling factor (.LE. 1), computed by SLALN2, which is * so chosen that X can be computed without overflow. X is further * scaled if necessary to assure that norm(ca A - w D)*norm(X) is less * than overflow. * * If both singular values of (ca A - w D) are less than SMIN, * SMIN*identity will be used instead of (ca A - w D). If only one * singular value is less than SMIN, one element of (ca A - w D) will be * perturbed enough to make the smallest singular value roughly SMIN. * If both singular values are at least SMIN, (ca A - w D) will not be * perturbed. In any case, the perturbation will be at most some small * multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values * are computed by infinity-norm approximations, and thus will only be * correct to a factor of 2 or so. * * Note: all input quantities are assumed to be smaller than overflow * by a reasonable factor. (See BIGNUM.) * * Arguments * ========== * * LTRANS (input) LOGICAL * =.TRUE.: A-transpose will be used. * =.FALSE.: A will be used (not transposed.) * * NA (input) INTEGER * The size of the matrix A. It may (only) be 1 or 2. * * NW (input) INTEGER * 1 if "w" is real, 2 if "w" is complex. It may only be 1 * or 2. * * SMIN (input) REAL * The desired lower bound on the singular values of A. This * should be a safe distance away from underflow or overflow, * say, between (underflow/machine precision) and (machine * precision * overflow ). (See BIGNUM and ULP.) * * CA (input) REAL * The coefficient c, which A is multiplied by. * * A (input) REAL array, dimension (LDA,NA) * The NA x NA matrix A. * * LDA (input) INTEGER * The leading dimension of A. It must be at least NA. * * D1 (input) REAL * The 1,1 element in the diagonal matrix D. * * D2 (input) REAL * The 2,2 element in the diagonal matrix D. Not used if NW=1. * * B (input) REAL array, dimension (LDB,NW) * The NA x NW matrix B (right-hand side). If NW=2 ("w" is * complex), column 1 contains the real part of B and column 2 * contains the imaginary part. * * LDB (input) INTEGER * The leading dimension of B. It must be at least NA. * * WR (input) REAL * The real part of the scalar "w". * * WI (input) REAL * The imaginary part of the scalar "w". Not used if NW=1. * * X (output) REAL array, dimension (LDX,NW) * The NA x NW matrix X (unknowns), as computed by SLALN2. * If NW=2 ("w" is complex), on exit, column 1 will contain * the real part of X and column 2 will contain the imaginary * part. * * LDX (input) INTEGER * The leading dimension of X. It must be at least NA. * * SCALE (output) REAL * The scale factor that B must be multiplied by to insure * that overflow does not occur when computing X. Thus, * (ca A - w D) X will be SCALE*B, not B (ignoring * perturbations of A.) It will be at most 1. * * XNORM (output) REAL * The infinity-norm of X, when X is regarded as an NA x NW * real matrix. * * INFO (output) INTEGER * An error flag. It will be set to zero if no error occurs, * a negative number if an argument is in error, or a positive * number if ca A - w D had to be perturbed. * The possible values are: * = 0: No error occurred, and (ca A - w D) did not have to be * perturbed. * = 1: (ca A - w D) had to be perturbed to make its smallest * (or only) singular value greater than SMIN. * NOTE: In the interests of speed, this routine does not * check the inputs for errors. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) * .. * .. Local Scalars .. INTEGER ICMAX, J REAL BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21, $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21, $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R, $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S, $ UR22, XI1, XI2, XR1, XR2 * .. * .. Local Arrays .. LOGICAL CSWAP( 4 ), RSWAP( 4 ) INTEGER IPIVOT( 4, 4 ) REAL CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 ) * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. External Subroutines .. EXTERNAL SLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Equivalences .. EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ), $ ( CR( 1, 1 ), CRV( 1 ) ) * .. * .. Data statements .. DATA CSWAP / .FALSE., .FALSE., .TRUE., .TRUE. / DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. / DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, $ 3, 2, 1 / * .. * .. Executable Statements .. * * Compute BIGNUM * SMLNUM = TWO*SLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM SMINI = MAX( SMIN, SMLNUM ) * * Don't check for input errors * INFO = 0 * * Standard Initializations * SCALE = ONE * IF( NA.EQ.1 ) THEN * * 1 x 1 (i.e., scalar) system C X = B * IF( NW.EQ.1 ) THEN * * Real 1x1 system. * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CNORM = ABS( CSR ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR XNORM = ABS( X( 1, 1 ) ) ELSE * * Complex 1x1 system (w is complex) * * C = ca A - w D * CSR = CA*A( 1, 1 ) - WR*D1 CSI = -WI*D1 CNORM = ABS( CSR ) + ABS( CSI ) * * If | C | < SMINI, use C = SMINI * IF( CNORM.LT.SMINI ) THEN CSR = SMINI CSI = ZERO CNORM = SMINI INFO = 1 END IF * * Check scaling for X = B / C * BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*CNORM ) $ SCALE = ONE / BNORM END IF * * Compute X * CALL SLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI, $ X( 1, 1 ), X( 1, 2 ) ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) END IF * ELSE * * 2x2 System * * Compute the real part of C = ca A - w D (or ca A' - w D ) * CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1 CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2 IF( LTRANS ) THEN CR( 1, 2 ) = CA*A( 2, 1 ) CR( 2, 1 ) = CA*A( 1, 2 ) ELSE CR( 2, 1 ) = CA*A( 2, 1 ) CR( 1, 2 ) = CA*A( 1, 2 ) END IF * IF( NW.EQ.1 ) THEN * * Real 2x2 system (w is real) * * Find the largest element in C * CMAX = ZERO ICMAX = 0 * DO 10 J = 1, 4 IF( ABS( CRV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) ICMAX = J END IF 10 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) UR11R = ONE / UR11 LR21 = UR11R*CR21 UR22 = CR22 - UR12*LR21 * * If smaller pivot < SMINI, use SMINI * IF( ABS( UR22 ).LT.SMINI ) THEN UR22 = SMINI INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR1 = B( 2, 1 ) BR2 = B( 1, 1 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) END IF BR2 = BR2 - LR21*BR1 BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) ) IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN IF( BBND.GE.BIGNUM*ABS( UR22 ) ) $ SCALE = ONE / BBND END IF * XR2 = ( BR2*SCALE ) / UR22 XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 ) IF( CSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 END IF XNORM = MAX( ABS( XR1 ), ABS( XR2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF ELSE * * Complex 2x2 system (w is complex) * * Find the largest element in C * CI( 1, 1 ) = -WI*D1 CI( 2, 1 ) = ZERO CI( 1, 2 ) = ZERO CI( 2, 2 ) = -WI*D2 CMAX = ZERO ICMAX = 0 * DO 20 J = 1, 4 IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) ) ICMAX = J END IF 20 CONTINUE * * If norm(C) < SMINI, use SMINI*identity. * IF( CMAX.LT.SMINI ) THEN BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN IF( BNORM.GT.BIGNUM*SMINI ) $ SCALE = ONE / BNORM END IF TEMP = SCALE / SMINI X( 1, 1 ) = TEMP*B( 1, 1 ) X( 2, 1 ) = TEMP*B( 2, 1 ) X( 1, 2 ) = TEMP*B( 1, 2 ) X( 2, 2 ) = TEMP*B( 2, 2 ) XNORM = TEMP*BNORM INFO = 1 RETURN END IF * * Gaussian elimination with complete pivoting. * UR11 = CRV( ICMAX ) UI11 = CIV( ICMAX ) CR21 = CRV( IPIVOT( 2, ICMAX ) ) CI21 = CIV( IPIVOT( 2, ICMAX ) ) UR12 = CRV( IPIVOT( 3, ICMAX ) ) UI12 = CIV( IPIVOT( 3, ICMAX ) ) CR22 = CRV( IPIVOT( 4, ICMAX ) ) CI22 = CIV( IPIVOT( 4, ICMAX ) ) IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN * * Code when off-diagonals of pivoted C are real * IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN TEMP = UI11 / UR11 UR11R = ONE / ( UR11*( ONE+TEMP**2 ) ) UI11R = -TEMP*UR11R ELSE TEMP = UR11 / UI11 UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) ) UR11R = -TEMP*UI11R END IF LR21 = CR21*UR11R LI21 = CR21*UI11R UR12S = UR12*UR11R UI12S = UR12*UI11R UR22 = CR22 - UR12*LR21 UI22 = CI22 - UR12*LI21 ELSE * * Code when diagonals of pivoted C are real * UR11R = ONE / UR11 UI11R = ZERO LR21 = CR21*UR11R LI21 = CI21*UR11R UR12S = UR12*UR11R UI12S = UI12*UR11R UR22 = CR22 - UR12*LR21 + UI12*LI21 UI22 = -UR12*LI21 - UI12*LR21 END IF U22ABS = ABS( UR22 ) + ABS( UI22 ) * * If smaller pivot < SMINI, use SMINI * IF( U22ABS.LT.SMINI ) THEN UR22 = SMINI UI22 = ZERO INFO = 1 END IF IF( RSWAP( ICMAX ) ) THEN BR2 = B( 1, 1 ) BR1 = B( 2, 1 ) BI2 = B( 1, 2 ) BI1 = B( 2, 2 ) ELSE BR1 = B( 1, 1 ) BR2 = B( 2, 1 ) BI1 = B( 1, 2 ) BI2 = B( 2, 2 ) END IF BR2 = BR2 - LR21*BR1 + LI21*BI1 BI2 = BI2 - LI21*BR1 - LR21*BI1 BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )* $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ), $ ABS( BR2 )+ABS( BI2 ) ) IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN IF( BBND.GE.BIGNUM*U22ABS ) THEN SCALE = ONE / BBND BR1 = SCALE*BR1 BI1 = SCALE*BI1 BR2 = SCALE*BR2 BI2 = SCALE*BI2 END IF END IF * CALL SLADIV( BR2, BI2, UR22, UI22, XR2, XI2 ) XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2 XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2 IF( CSWAP( ICMAX ) ) THEN X( 1, 1 ) = XR2 X( 2, 1 ) = XR1 X( 1, 2 ) = XI2 X( 2, 2 ) = XI1 ELSE X( 1, 1 ) = XR1 X( 2, 1 ) = XR2 X( 1, 2 ) = XI1 X( 2, 2 ) = XI2 END IF XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) ) * * Further scaling if norm(A) norm(X) > overflow * IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN IF( XNORM.GT.BIGNUM / CMAX ) THEN TEMP = CMAX / BIGNUM X( 1, 1 ) = TEMP*X( 1, 1 ) X( 2, 1 ) = TEMP*X( 2, 1 ) X( 1, 2 ) = TEMP*X( 1, 2 ) X( 2, 2 ) = TEMP*X( 2, 2 ) XNORM = TEMP*XNORM SCALE = TEMP*SCALE END IF END IF END IF END IF * RETURN * * End of SLALN2 * END arpack-akloeckner-07/LAPACK/slamch.f0000644000175000017500000006037406153460172017062 0ustar andreasandreas REAL FUNCTION SLAMCH( CMACH ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER CMACH * .. * * Purpose * ======= * * SLAMCH determines single precision machine parameters. * * Arguments * ========= * * CMACH (input) CHARACTER*1 * Specifies the value to be returned by SLAMCH: * = 'E' or 'e', SLAMCH := eps * = 'S' or 's , SLAMCH := sfmin * = 'B' or 'b', SLAMCH := base * = 'P' or 'p', SLAMCH := eps*base * = 'N' or 'n', SLAMCH := t * = 'R' or 'r', SLAMCH := rnd * = 'M' or 'm', SLAMCH := emin * = 'U' or 'u', SLAMCH := rmin * = 'L' or 'l', SLAMCH := emax * = 'O' or 'o', SLAMCH := rmax * * where * * eps = relative machine precision * sfmin = safe minimum, such that 1/sfmin does not overflow * base = base of the machine * prec = eps*base * t = number of (base) digits in the mantissa * rnd = 1.0 when rounding occurs in addition, 0.0 otherwise * emin = minimum exponent before (gradual) underflow * rmin = underflow threshold - base**(emin-1) * emax = largest exponent before overflow * rmax = overflow threshold - (base**emax)*(1-eps) * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL FIRST, LRND INTEGER BETA, IMAX, IMIN, IT REAL BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, $ RND, SFMIN, SMALL, T * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLAMC2 * .. * .. Save statement .. SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, $ EMAX, RMAX, PREC * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) BASE = BETA T = IT IF( LRND ) THEN RND = ONE EPS = ( BASE**( 1-IT ) ) / 2 ELSE RND = ZERO EPS = BASE**( 1-IT ) END IF PREC = EPS*BASE EMIN = IMIN EMAX = IMAX SFMIN = RMIN SMALL = ONE / RMAX IF( SMALL.GE.SFMIN ) THEN * * Use SMALL plus a bit, to avoid the possibility of rounding * causing overflow when computing 1/sfmin. * SFMIN = SMALL*( ONE+EPS ) END IF END IF * IF( LSAME( CMACH, 'E' ) ) THEN RMACH = EPS ELSE IF( LSAME( CMACH, 'S' ) ) THEN RMACH = SFMIN ELSE IF( LSAME( CMACH, 'B' ) ) THEN RMACH = BASE ELSE IF( LSAME( CMACH, 'P' ) ) THEN RMACH = PREC ELSE IF( LSAME( CMACH, 'N' ) ) THEN RMACH = T ELSE IF( LSAME( CMACH, 'R' ) ) THEN RMACH = RND ELSE IF( LSAME( CMACH, 'M' ) ) THEN RMACH = EMIN ELSE IF( LSAME( CMACH, 'U' ) ) THEN RMACH = RMIN ELSE IF( LSAME( CMACH, 'L' ) ) THEN RMACH = EMAX ELSE IF( LSAME( CMACH, 'O' ) ) THEN RMACH = RMAX END IF * SLAMCH = RMACH RETURN * * End of SLAMCH * END * ************************************************************************ * SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE1, RND INTEGER BETA, T * .. * * Purpose * ======= * * SLAMC1 determines the machine parameters given by BETA, T, RND, and * IEEE1. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * IEEE1 (output) LOGICAL * Specifies whether rounding appears to be done in the IEEE * 'round to nearest' style. * * Further Details * =============== * * The routine is based on the routine ENVRON by Malcolm and * incorporates suggestions by Gentleman and Marovich. See * * Malcolm M. A. (1972) Algorithms to reveal properties of * floating-point arithmetic. Comms. of the ACM, 15, 949-951. * * Gentleman W. M. and Marovich S. B. (1974) More on algorithms * that reveal properties of floating point arithmetic units. * Comms. of the ACM, 17, 276-277. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, LIEEE1, LRND INTEGER LBETA, LT REAL A, B, C, F, ONE, QTR, SAVEC, T1, T2 * .. * .. External Functions .. REAL SLAMC3 EXTERNAL SLAMC3 * .. * .. Save statement .. SAVE FIRST, LIEEE1, LBETA, LRND, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ONE = 1 * * LBETA, LIEEE1, LT and LRND are the local values of BETA, * IEEE1, T and RND. * * Throughout this routine we use the function SLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * Compute a = 2.0**m with the smallest positive integer m such * that * * fl( a + 1.0 ) = a. * A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 10 CONTINUE IF( C.EQ.ONE ) THEN A = 2*A C = SLAMC3( A, ONE ) C = SLAMC3( C, -A ) GO TO 10 END IF *+ END WHILE * * Now compute b = 2.0**m with the smallest positive integer m * such that * * fl( a + b ) .gt. a. * B = 1 C = SLAMC3( A, B ) * *+ WHILE( C.EQ.A )LOOP 20 CONTINUE IF( C.EQ.A ) THEN B = 2*B C = SLAMC3( A, B ) GO TO 20 END IF *+ END WHILE * * Now compute the base. a and c are neighbouring floating point * numbers in the interval ( beta**t, beta**( t + 1 ) ) and so * their difference is beta. Adding 0.25 to c is to ensure that it * is truncated to beta and not ( beta - 1 ). * QTR = ONE / 4 SAVEC = C C = SLAMC3( C, -A ) LBETA = C + QTR * * Now determine whether rounding or chopping occurs, by adding a * bit less than beta/2 and a bit more than beta/2 to a. * B = LBETA F = SLAMC3( B / 2, -B / 100 ) C = SLAMC3( F, A ) IF( C.EQ.A ) THEN LRND = .TRUE. ELSE LRND = .FALSE. END IF F = SLAMC3( B / 2, B / 100 ) C = SLAMC3( F, A ) IF( ( LRND ) .AND. ( C.EQ.A ) ) $ LRND = .FALSE. * * Try and decide whether rounding is done in the IEEE 'round to * nearest' style. B/2 is half a unit in the last place of the two * numbers A and SAVEC. Furthermore, A is even, i.e. has last bit * zero, and SAVEC is odd. Thus adding B/2 to A should not change * A, but adding B/2 to SAVEC should change SAVEC. * T1 = SLAMC3( B / 2, A ) T2 = SLAMC3( B / 2, SAVEC ) LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND * * Now find the mantissa, t. It should be the integer part of * log to the base beta of a, however it is safer to determine t * by powering. So we find t as the smallest positive integer for * which * * fl( beta**t + 1.0 ) = 1.0. * LT = 0 A = 1 C = 1 * *+ WHILE( C.EQ.ONE )LOOP 30 CONTINUE IF( C.EQ.ONE ) THEN LT = LT + 1 A = A*LBETA C = SLAMC3( A, ONE ) C = SLAMC3( C, -A ) GO TO 30 END IF *+ END WHILE * END IF * BETA = LBETA T = LT RND = LRND IEEE1 = LIEEE1 RETURN * * End of SLAMC1 * END * ************************************************************************ * SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL RND INTEGER BETA, EMAX, EMIN, T REAL EPS, RMAX, RMIN * .. * * Purpose * ======= * * SLAMC2 determines the machine parameters specified in its argument * list. * * Arguments * ========= * * BETA (output) INTEGER * The base of the machine. * * T (output) INTEGER * The number of ( BETA ) digits in the mantissa. * * RND (output) LOGICAL * Specifies whether proper rounding ( RND = .TRUE. ) or * chopping ( RND = .FALSE. ) occurs in addition. This may not * be a reliable guide to the way in which the machine performs * its arithmetic. * * EPS (output) REAL * The smallest positive number such that * * fl( 1.0 - EPS ) .LT. 1.0, * * where fl denotes the computed value. * * EMIN (output) INTEGER * The minimum exponent before (gradual) underflow occurs. * * RMIN (output) REAL * The smallest normalized number for the machine, given by * BASE**( EMIN - 1 ), where BASE is the floating point value * of BETA. * * EMAX (output) INTEGER * The maximum exponent before overflow occurs. * * RMAX (output) REAL * The largest positive number for the machine, given by * BASE**EMAX * ( 1 - EPS ), where BASE is the floating point * value of BETA. * * Further Details * =============== * * The computation of EPS is based on a routine PARANOIA by * W. Kahan of the University of California at Berkeley. * * ===================================================================== * * .. Local Scalars .. LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, $ NGNMIN, NGPMIN REAL A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, $ SIXTH, SMALL, THIRD, TWO, ZERO * .. * .. External Functions .. REAL SLAMC3 EXTERNAL SLAMC3 * .. * .. External Subroutines .. EXTERNAL SLAMC1, SLAMC4, SLAMC5 * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. Save statement .. SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, $ LRMIN, LT * .. * .. Data statements .. DATA FIRST / .TRUE. / , IWARN / .FALSE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. ZERO = 0 ONE = 1 TWO = 2 * * LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of * BETA, T, RND, EPS, EMIN and RMIN. * * Throughout this routine we use the function SLAMC3 to ensure * that relevant values are stored and not held in registers, or * are not affected by optimizers. * * SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. * CALL SLAMC1( LBETA, LT, LRND, LIEEE1 ) * * Start to find EPS. * B = LBETA A = B**( -LT ) LEPS = A * * Try some tricks to see whether or not this is the correct EPS. * B = TWO / 3 HALF = ONE / 2 SIXTH = SLAMC3( B, -HALF ) THIRD = SLAMC3( SIXTH, SIXTH ) B = SLAMC3( THIRD, -HALF ) B = SLAMC3( B, SIXTH ) B = ABS( B ) IF( B.LT.LEPS ) $ B = LEPS * LEPS = 1 * *+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP 10 CONTINUE IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN LEPS = B C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) C = SLAMC3( HALF, -C ) B = SLAMC3( HALF, C ) C = SLAMC3( HALF, -B ) B = SLAMC3( HALF, C ) GO TO 10 END IF *+ END WHILE * IF( A.LT.LEPS ) $ LEPS = A * * Computation of EPS complete. * * Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). * Keep dividing A by BETA until (gradual) underflow occurs. This * is detected when we cannot recover the previous A. * RBASE = ONE / LBETA SMALL = ONE DO 20 I = 1, 3 SMALL = SLAMC3( SMALL*RBASE, ZERO ) 20 CONTINUE A = SLAMC3( ONE, SMALL ) CALL SLAMC4( NGPMIN, ONE, LBETA ) CALL SLAMC4( NGNMIN, -ONE, LBETA ) CALL SLAMC4( GPMIN, A, LBETA ) CALL SLAMC4( GNMIN, -A, LBETA ) IEEE = .FALSE. * IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN IF( NGPMIN.EQ.GPMIN ) THEN LEMIN = NGPMIN * ( Non twos-complement machines, no gradual underflow; * e.g., VAX ) ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN LEMIN = NGPMIN - 1 + LT IEEE = .TRUE. * ( Non twos-complement machines, with gradual underflow; * e.g., IEEE standard followers ) ELSE LEMIN = MIN( NGPMIN, GPMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) * ( Twos-complement machines, no gradual underflow; * e.g., CYBER 205 ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. $ ( GPMIN.EQ.GNMIN ) ) THEN IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT * ( Twos-complement machines with gradual underflow; * no known machine ) ELSE LEMIN = MIN( NGPMIN, NGNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF * ELSE LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) * ( A guess; no known machine ) IWARN = .TRUE. END IF *** * Comment out this if block if EMIN is ok IF( IWARN ) THEN FIRST = .TRUE. WRITE( 6, FMT = 9999 )LEMIN END IF *** * * Assume IEEE arithmetic if we found denormalised numbers above, * or if arithmetic seems to round in the IEEE style, determined * in routine SLAMC1. A true IEEE machine should have both things * true; however, faulty machines may have one or the other. * IEEE = IEEE .OR. LIEEE1 * * Compute RMIN by successive division by BETA. We could compute * RMIN as BASE**( EMIN - 1 ), but some machines underflow during * this computation. * LRMIN = 1 DO 30 I = 1, 1 - LEMIN LRMIN = SLAMC3( LRMIN*RBASE, ZERO ) 30 CONTINUE * * Finally, call SLAMC5 to compute EMAX and RMAX. * CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) END IF * BETA = LBETA T = LT RND = LRND EPS = LEPS EMIN = LEMIN RMIN = LRMIN EMAX = LEMAX RMAX = LRMAX * RETURN * 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', $ ' EMIN = ', I8, / $ ' If, after inspection, the value EMIN looks', $ ' acceptable please comment out ', $ / ' the IF block as marked within the code of routine', $ ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / ) * * End of SLAMC2 * END * ************************************************************************ * REAL FUNCTION SLAMC3( A, B ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. REAL A, B * .. * * Purpose * ======= * * SLAMC3 is intended to force A and B to be stored prior to doing * the addition of A and B , for use in situations where optimizers * might hold one of these in a register. * * Arguments * ========= * * A, B (input) REAL * The values A and B. * * ===================================================================== * * .. Executable Statements .. * SLAMC3 = A + B * RETURN * * End of SLAMC3 * END * ************************************************************************ * SUBROUTINE SLAMC4( EMIN, START, BASE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER BASE, EMIN REAL START * .. * * Purpose * ======= * * SLAMC4 is a service routine for SLAMC2. * * Arguments * ========= * * EMIN (output) EMIN * The minimum exponent before (gradual) underflow, computed by * setting A = START and dividing by BASE until the previous A * can not be recovered. * * START (input) REAL * The starting point for determining EMIN. * * BASE (input) INTEGER * The base of the machine. * * ===================================================================== * * .. Local Scalars .. INTEGER I REAL A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO * .. * .. External Functions .. REAL SLAMC3 EXTERNAL SLAMC3 * .. * .. Executable Statements .. * A = START ONE = 1 RBASE = ONE / BASE ZERO = 0 EMIN = 1 B1 = SLAMC3( A*RBASE, ZERO ) C1 = A C2 = A D1 = A D2 = A *+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. * $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP 10 CONTINUE IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. $ ( D2.EQ.A ) ) THEN EMIN = EMIN - 1 A = B1 B1 = SLAMC3( A / BASE, ZERO ) C1 = SLAMC3( B1*BASE, ZERO ) D1 = ZERO DO 20 I = 1, BASE D1 = D1 + B1 20 CONTINUE B2 = SLAMC3( A*RBASE, ZERO ) C2 = SLAMC3( B2 / RBASE, ZERO ) D2 = ZERO DO 30 I = 1, BASE D2 = D2 + B2 30 CONTINUE GO TO 10 END IF *+ END WHILE * RETURN * * End of SLAMC4 * END * ************************************************************************ * SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL IEEE INTEGER BETA, EMAX, EMIN, P REAL RMAX * .. * * Purpose * ======= * * SLAMC5 attempts to compute RMAX, the largest machine floating-point * number, without overflow. It assumes that EMAX + abs(EMIN) sum * approximately to a power of 2. It will fail on machines where this * assumption does not hold, for example, the Cyber 205 (EMIN = -28625, * EMAX = 28718). It will also fail if the value supplied for EMIN is * too large (i.e. too close to zero), probably with overflow. * * Arguments * ========= * * BETA (input) INTEGER * The base of floating-point arithmetic. * * P (input) INTEGER * The number of base BETA digits in the mantissa of a * floating-point value. * * EMIN (input) INTEGER * The minimum exponent before (gradual) underflow. * * IEEE (input) LOGICAL * A logical flag specifying whether or not the arithmetic * system is thought to comply with the IEEE standard. * * EMAX (output) INTEGER * The largest exponent before overflow * * RMAX (output) REAL * The largest machine floating-point number. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP REAL OLDY, RECBAS, Y, Z * .. * .. External Functions .. REAL SLAMC3 EXTERNAL SLAMC3 * .. * .. Intrinsic Functions .. INTRINSIC MOD * .. * .. Executable Statements .. * * First compute LEXP and UEXP, two powers of 2 that bound * abs(EMIN). We then assume that EMAX + abs(EMIN) will sum * approximately to the bound that is closest to abs(EMIN). * (EMAX is the exponent of the required number RMAX). * LEXP = 1 EXBITS = 1 10 CONTINUE TRY = LEXP*2 IF( TRY.LE.( -EMIN ) ) THEN LEXP = TRY EXBITS = EXBITS + 1 GO TO 10 END IF IF( LEXP.EQ.-EMIN ) THEN UEXP = LEXP ELSE UEXP = TRY EXBITS = EXBITS + 1 END IF * * Now -LEXP is less than or equal to EMIN, and -UEXP is greater * than or equal to EMIN. EXBITS is the number of bits needed to * store the exponent. * IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN EXPSUM = 2*LEXP ELSE EXPSUM = 2*UEXP END IF * * EXPSUM is the exponent range, approximately equal to * EMAX - EMIN + 1 . * EMAX = EXPSUM + EMIN - 1 NBITS = 1 + EXBITS + P * * NBITS is the total number of bits needed to store a * floating-point number. * IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN * * Either there are an odd number of bits used to store a * floating-point number, which is unlikely, or some bits are * not used in the representation of numbers, which is possible, * (e.g. Cray machines) or the mantissa has an implicit bit, * (e.g. IEEE machines, Dec Vax machines), which is perhaps the * most likely. We have to assume the last alternative. * If this is true, then we need to reduce EMAX by one because * there must be some way of representing zero in an implicit-bit * system. On machines like Cray, we are reducing EMAX by one * unnecessarily. * EMAX = EMAX - 1 END IF * IF( IEEE ) THEN * * Assume we are on an IEEE machine which reserves one exponent * for infinity and NaN. * EMAX = EMAX - 1 END IF * * Now create RMAX, the largest machine number, which should * be equal to (1.0 - BETA**(-P)) * BETA**EMAX . * * First compute 1.0 - BETA**(-P), being careful that the * result is less than 1.0 . * RECBAS = ONE / BETA Z = BETA - ONE Y = ZERO DO 20 I = 1, P Z = Z*RECBAS IF( Y.LT.ONE ) $ OLDY = Y Y = SLAMC3( Y, Z ) 20 CONTINUE IF( Y.GE.ONE ) $ Y = OLDY * * Now multiply by BETA**EMAX to get RMAX. * DO 30 I = 1, EMAX Y = SLAMC3( Y*BETA, ZERO ) 30 CONTINUE * RMAX = Y RETURN * * End of SLAMC5 * END arpack-akloeckner-07/LAPACK/slange.f0000644000175000017500000000762606153460172017065 0ustar andreasandreas REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * SLANGE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * real matrix A. * * Description * =========== * * SLANGE returns the value * * SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in SLANGE as described * above. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. When M = 0, * SLANGE is set to zero. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. When N = 0, * SLANGE is set to zero. * * A (input) REAL array, dimension (LDA,N) * The m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * * WORK (workspace) REAL array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, M SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, M WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, M VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL SLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * SLANGE = VALUE RETURN * * End of SLANGE * END arpack-akloeckner-07/LAPACK/slanhs.f0000644000175000017500000000760606153460172017102 0ustar andreasandreas REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N * .. * .. Array Arguments .. REAL A( LDA, * ), WORK( * ) * .. * * Purpose * ======= * * SLANHS returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * Hessenberg matrix A. * * Description * =========== * * SLANHS returns the value * * SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in SLANHS as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, SLANHS is * set to zero. * * A (input) REAL array, dimension (LDA,N) * The n by n upper Hessenberg matrix A; the part of A below the * first sub-diagonal is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) REAL array, dimension (LWORK), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J REAL SCALE, SUM, VALUE * .. * .. External Subroutines .. EXTERNAL SLASSQ * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * SLANHS = VALUE RETURN * * End of SLANHS * END arpack-akloeckner-07/LAPACK/slanst.f0000644000175000017500000000673106153460172017114 0ustar andreasandreas REAL FUNCTION SLANST( NORM, N, D, E ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER N * .. * .. Array Arguments .. REAL D( * ), E( * ) * .. * * Purpose * ======= * * SLANST returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * real symmetric tridiagonal matrix A. * * Description * =========== * * SLANST returns the value * * SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in SLANST as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, SLANST is * set to zero. * * D (input) REAL array, dimension (N) * The diagonal elements of A. * * E (input) REAL array, dimension (N-1) * The (n-1) sub-diagonal or super-diagonal elements of A. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I REAL ANORM, SCALE, SUM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN ANORM = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * ANORM = ABS( D( N ) ) DO 10 I = 1, N - 1 ANORM = MAX( ANORM, ABS( D( I ) ) ) ANORM = MAX( ANORM, ABS( E( I ) ) ) 10 CONTINUE ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. $ LSAME( NORM, 'I' ) ) THEN * * Find norm1(A). * IF( N.EQ.1 ) THEN ANORM = ABS( D( 1 ) ) ELSE ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), $ ABS( E( N-1 ) )+ABS( D( N ) ) ) DO 20 I = 2, N - 1 ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ $ ABS( E( I-1 ) ) ) 20 CONTINUE END IF ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE IF( N.GT.1 ) THEN CALL SLASSQ( N-1, E, 1, SCALE, SUM ) SUM = 2*SUM END IF CALL SLASSQ( N, D, 1, SCALE, SUM ) ANORM = SCALE*SQRT( SUM ) END IF * SLANST = ANORM RETURN * * End of SLANST * END arpack-akloeckner-07/LAPACK/slanv2.f0000644000175000017500000001077106153460172017014 0ustar andreasandreas SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. REAL A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN * .. * * Purpose * ======= * * SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric * matrix in standard form: * * [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] * [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] * * where either * 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or * 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex * conjugate eigenvalues. * * Arguments * ========= * * A (input/output) REAL * B (input/output) REAL * C (input/output) REAL * D (input/output) REAL * On entry, the elements of the input matrix. * On exit, they are overwritten by the elements of the * standardised Schur form. * * RT1R (output) REAL * RT1I (output) REAL * RT2R (output) REAL * RT2I (output) REAL * The real and imaginary parts of the eigenvalues. If the * eigenvalues are both real, abs(RT1R) >= abs(RT2R); if the * eigenvalues are a complex conjugate pair, RT1I > 0. * * CS (output) REAL * SN (output) REAL * Parameters of the rotation matrix. * * ===================================================================== * * .. Parameters .. REAL ZERO, HALF, ONE PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. REAL AA, BB, CC, CS1, DD, P, SAB, SAC, SIGMA, SN1, $ TAU, TEMP * .. * .. External Functions .. REAL SLAPY2 EXTERNAL SLAPY2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT * .. * .. Executable Statements .. * * Initialize CS and SN * CS = ONE SN = ZERO * IF( C.EQ.ZERO ) THEN GO TO 10 * ELSE IF( B.EQ.ZERO ) THEN * * Swap rows and columns * CS = ZERO SN = ONE TEMP = D D = A A = TEMP B = -C C = ZERO GO TO 10 ELSE IF( (A-D).EQ.ZERO .AND. SIGN( ONE, B ).NE. $ SIGN( ONE, C ) ) THEN GO TO 10 ELSE * * Make diagonal elements equal * TEMP = A - D P = HALF*TEMP SIGMA = B + C TAU = SLAPY2( SIGMA, TEMP ) CS1 = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) ) SN1 = -( P / ( TAU*CS1 ) )*SIGN( ONE, SIGMA ) * * Compute [ AA BB ] = [ A B ] [ CS1 -SN1 ] * [ CC DD ] [ C D ] [ SN1 CS1 ] * AA = A*CS1 + B*SN1 BB = -A*SN1 + B*CS1 CC = C*CS1 + D*SN1 DD = -C*SN1 + D*CS1 * * Compute [ A B ] = [ CS1 SN1 ] [ AA BB ] * [ C D ] [-SN1 CS1 ] [ CC DD ] * A = AA*CS1 + CC*SN1 B = BB*CS1 + DD*SN1 C = -AA*SN1 + CC*CS1 D = -BB*SN1 + DD*CS1 * * Accumulate transformation * TEMP = CS*CS1 - SN*SN1 SN = CS*SN1 + SN*CS1 CS = TEMP * TEMP = HALF*( A+D ) A = TEMP D = TEMP * IF( C.NE.ZERO ) THEN IF ( B.NE.ZERO ) THEN IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN * * Real eigenvalues: reduce to upper triangular form * SAB = SQRT( ABS( B ) ) SAC = SQRT( ABS( C ) ) P = SIGN( SAB*SAC, C ) TAU = ONE / SQRT( ABS( B+C ) ) A = TEMP + P D = TEMP - P B = B - C C = ZERO CS1 = SAB*TAU SN1 = SAC*TAU TEMP = CS*CS1 - SN*SN1 SN = CS*SN1 + SN*CS1 CS = TEMP END IF ELSE B = -C C = ZERO TEMP = CS CS = -SN SN = TEMP ENDIF ENDIF END IF * 10 CONTINUE * * Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). * RT1R = A RT2R = D IF( C.EQ.ZERO ) THEN RT1I = ZERO RT2I = ZERO ELSE RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) ) RT2I = -RT1I END IF RETURN * * End of SLANV2 * END arpack-akloeckner-07/LAPACK/slaptm.f0000644000175000017500000000770706153460172017114 0ustar andreasandreas SUBROUTINE SLAPTM( N, NRHS, ALPHA, D, E, X, LDX, BETA, B, LDB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER LDB, LDX, N, NRHS REAL ALPHA, BETA * .. * .. Array Arguments .. REAL B( LDB, * ), D( * ), E( * ), X( LDX, * ) * .. * * Purpose * ======= * * SLAPTM multiplies an N by NRHS matrix X by a symmetric tridiagonal * matrix A and stores the result in a matrix B. The operation has the * form * * B := alpha * A * X + beta * B * * where alpha may be either 1. or -1. and beta may be 0., 1., or -1. * * Arguments * ========= * * 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 matrices X and B. * * ALPHA (input) REAL * The scalar alpha. ALPHA must be 1. or -1.; otherwise, * it is assumed to be 0. * * D (input) REAL array, dimension (N) * The n diagonal elements of the tridiagonal matrix A. * * E (input) REAL array, dimension (N-1) * The (n-1) subdiagonal or superdiagonal elements of A. * * X (input) REAL array, dimension (LDX,NRHS) * The N by NRHS matrix X. * * LDX (input) INTEGER * The leading dimension of the array X. LDX >= max(N,1). * * BETA (input) REAL * The scalar beta. BETA must be 0., 1., or -1.; otherwise, * it is assumed to be 1. * * B (input/output) REAL array, dimension (LDB,NRHS) * On entry, the N by NRHS matrix B. * On exit, B is overwritten by the matrix expression * B := alpha * A * X + beta * B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(N,1). * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, J * .. * .. Executable Statements .. * IF( N.EQ.0 ) $ RETURN * * Multiply B by BETA if BETA.NE.1. * IF( BETA.EQ.ZERO ) THEN DO 20 J = 1, NRHS DO 10 I = 1, N B( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE IF( BETA.EQ.-ONE ) THEN DO 40 J = 1, NRHS DO 30 I = 1, N B( I, J ) = -B( I, J ) 30 CONTINUE 40 CONTINUE END IF * IF( ALPHA.EQ.ONE ) THEN * * Compute B := B + A*X * DO 60 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) + $ E( 1 )*X( 2, J ) B( N, J ) = B( N, J ) + E( N-1 )*X( N-1, J ) + $ D( N )*X( N, J ) DO 50 I = 2, N - 1 B( I, J ) = B( I, J ) + E( I-1 )*X( I-1, J ) + $ D( I )*X( I, J ) + E( I )*X( I+1, J ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( ALPHA.EQ.-ONE ) THEN * * Compute B := B - A*X * DO 80 J = 1, NRHS IF( N.EQ.1 ) THEN B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) ELSE B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) - $ E( 1 )*X( 2, J ) B( N, J ) = B( N, J ) - E( N-1 )*X( N-1, J ) - $ D( N )*X( N, J ) DO 70 I = 2, N - 1 B( I, J ) = B( I, J ) - E( I-1 )*X( I-1, J ) - $ D( I )*X( I, J ) - E( I )*X( I+1, J ) 70 CONTINUE END IF 80 CONTINUE END IF RETURN * * End of SLAPTM * END arpack-akloeckner-07/LAPACK/slapy2.f0000644000175000017500000000237006153460172017015 0ustar andreasandreas REAL FUNCTION SLAPY2( X, Y ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. REAL X, Y * .. * * Purpose * ======= * * SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary * overflow. * * Arguments * ========= * * X (input) REAL * Y (input) REAL * X and Y specify the values x and y. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) * .. * .. Local Scalars .. REAL W, XABS, YABS, Z * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) W = MAX( XABS, YABS ) Z = MIN( XABS, YABS ) IF( Z.EQ.ZERO ) THEN SLAPY2 = W ELSE SLAPY2 = W*SQRT( ONE+( Z / W )**2 ) END IF RETURN * * End of SLAPY2 * END arpack-akloeckner-07/LAPACK/slapy3.f0000644000175000017500000000241606153460172017017 0ustar andreasandreas REAL FUNCTION SLAPY3( X, Y, Z ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. REAL X, Y, Z * .. * * Purpose * ======= * * SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause * unnecessary overflow. * * Arguments * ========= * * X (input) REAL * Y (input) REAL * Z (input) REAL * X, Y and Z specify the values x, y and z. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) * .. * .. Local Scalars .. REAL W, XABS, YABS, ZABS * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * XABS = ABS( X ) YABS = ABS( Y ) ZABS = ABS( Z ) W = MAX( XABS, YABS, ZABS ) IF( W.EQ.ZERO ) THEN SLAPY3 = ZERO ELSE SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+ $ ( ZABS / W )**2 ) END IF RETURN * * End of SLAPY3 * END arpack-akloeckner-07/LAPACK/slaran.f0000644000175000017500000000511706153460173017066 0ustar andreasandreas REAL FUNCTION SLARAN( ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * SLARAN returns a random real number from a uniform (0,1) * distribution. * * Arguments * ========= * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine uses a multiplicative congruential method with modulus * 2**48 and multiplier 33952834046453 (see G.S.Fishman, * 'Multiplicative congruential random number generators with modulus * 2**b: an exhaustive analysis for b = 32 and a partial analysis for * b = 48', Math. Comp. 189, pp 331-344, 1990). * * 48-bit integers are stored in 4 integer array elements with 12 bits * per element. Hence the routine is portable across machines with * integers of 32 bits or more. * * ===================================================================== * * .. Parameters .. INTEGER M1, M2, M3, M4 PARAMETER ( M1 = 494, M2 = 322, M3 = 2508, M4 = 2549 ) REAL ONE PARAMETER ( ONE = 1.0E+0 ) INTEGER IPW2 REAL R PARAMETER ( IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER IT1, IT2, IT3, IT4 * .. * .. Intrinsic Functions .. INTRINSIC MOD, REAL * .. * .. Executable Statements .. * * multiply the seed by the multiplier modulo 2**48 * IT4 = ISEED( 4 )*M4 IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + ISEED( 3 )*M4 + ISEED( 4 )*M3 IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2 IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 + $ ISEED( 4 )*M1 IT1 = MOD( IT1, IPW2 ) * * return updated seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 * * convert 48-bit integer to a real number in the interval (0,1) * SLARAN = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R* $ ( REAL( IT4 ) ) ) ) ) RETURN * * End of SLARAN * END arpack-akloeckner-07/LAPACK/slarfg.f0000644000175000017500000000677306153460173017075 0ustar andreasandreas SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N REAL ALPHA, TAU * .. * .. Array Arguments .. REAL X( * ) * .. * * Purpose * ======= * * SLARFG generates a real elementary reflector H of order n, such * that * * H * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, and x is an (n-1)-element real * vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a real scalar and v is a real (n-1)-element * vector. * * If the elements of x are all zero, then tau = 0 and H is taken to be * the unit matrix. * * Otherwise 1 <= tau <= 2. * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) REAL * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) REAL array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX > 0. * * TAU (output) REAL * The value tau. * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER J, KNT REAL BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. REAL SLAMCH, SLAPY2, SNRM2 EXTERNAL SLAMCH, SLAPY2, SNRM2 * .. * .. Intrinsic Functions .. INTRINSIC ABS, SIGN * .. * .. External Subroutines .. EXTERNAL SSCAL * .. * .. Executable Statements .. * IF( N.LE.1 ) THEN TAU = ZERO RETURN END IF * XNORM = SNRM2( N-1, X, INCX ) * IF( XNORM.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA ) SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' ) IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * RSAFMN = ONE / SAFMIN KNT = 0 10 CONTINUE KNT = KNT + 1 CALL SSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHA = ALPHA*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = SNRM2( N-1, X, INCX ) BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA ) TAU = ( BETA-ALPHA ) / BETA CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = ( BETA-ALPHA ) / BETA CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of SLARFG * END arpack-akloeckner-07/LAPACK/slarfx.f0000644000175000017500000004240706153460173017110 0ustar andreasandreas SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER LDC, M, N REAL TAU * .. * .. Array Arguments .. REAL C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * SLARFX applies a real elementary reflector H to a real m by n * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a real scalar and v is a real vector. * * If tau = 0, then H is taken to be the unit matrix * * This version uses inline code if H has order < 11. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) REAL array, dimension (M) if SIDE = 'L' * or (N) if SIDE = 'R' * The vector v in the representation of H. * * TAU (input) REAL * The value tau in the representation of H. * * C (input/output) REAL array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDA >= (1,M). * * WORK (workspace) REAL array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * WORK is not referenced if H has order < 11. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER J REAL SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9, $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SGEMV, SGER * .. * .. Executable Statements .. * IF( TAU.EQ.ZERO ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C, where H has order m. * GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, $ 170, 190 )M * * Code for general M * * w := C'*v * CALL SGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK, $ 1 ) * * C := C - tau * v * w' * CALL SGER( M, N, -TAU, V, 1, WORK, 1, C, LDC ) GO TO 410 10 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 20 J = 1, N C( 1, J ) = T1*C( 1, J ) 20 CONTINUE GO TO 410 30 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 40 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 40 CONTINUE GO TO 410 50 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 60 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 60 CONTINUE GO TO 410 70 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 80 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 80 CONTINUE GO TO 410 90 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 100 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 100 CONTINUE GO TO 410 110 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 120 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 120 CONTINUE GO TO 410 130 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 140 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 140 CONTINUE GO TO 410 150 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 160 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 160 CONTINUE GO TO 410 170 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 180 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 180 CONTINUE GO TO 410 190 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 200 J = 1, N SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) + $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) + $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) + $ V10*C( 10, J ) C( 1, J ) = C( 1, J ) - SUM*T1 C( 2, J ) = C( 2, J ) - SUM*T2 C( 3, J ) = C( 3, J ) - SUM*T3 C( 4, J ) = C( 4, J ) - SUM*T4 C( 5, J ) = C( 5, J ) - SUM*T5 C( 6, J ) = C( 6, J ) - SUM*T6 C( 7, J ) = C( 7, J ) - SUM*T7 C( 8, J ) = C( 8, J ) - SUM*T8 C( 9, J ) = C( 9, J ) - SUM*T9 C( 10, J ) = C( 10, J ) - SUM*T10 200 CONTINUE GO TO 410 ELSE * * Form C * H, where H has order n. * GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, $ 370, 390 )N * * Code for general N * * w := C * v * CALL SGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO, $ WORK, 1 ) * * C := C - tau * w * v' * CALL SGER( M, N, -TAU, WORK, 1, V, 1, C, LDC ) GO TO 410 210 CONTINUE * * Special code for 1 x 1 Householder * T1 = ONE - TAU*V( 1 )*V( 1 ) DO 220 J = 1, M C( J, 1 ) = T1*C( J, 1 ) 220 CONTINUE GO TO 410 230 CONTINUE * * Special code for 2 x 2 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 DO 240 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 240 CONTINUE GO TO 410 250 CONTINUE * * Special code for 3 x 3 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 DO 260 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 260 CONTINUE GO TO 410 270 CONTINUE * * Special code for 4 x 4 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 DO 280 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 280 CONTINUE GO TO 410 290 CONTINUE * * Special code for 5 x 5 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 DO 300 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 300 CONTINUE GO TO 410 310 CONTINUE * * Special code for 6 x 6 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 DO 320 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 320 CONTINUE GO TO 410 330 CONTINUE * * Special code for 7 x 7 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 DO 340 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 340 CONTINUE GO TO 410 350 CONTINUE * * Special code for 8 x 8 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 DO 360 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 360 CONTINUE GO TO 410 370 CONTINUE * * Special code for 9 x 9 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 DO 380 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 380 CONTINUE GO TO 410 390 CONTINUE * * Special code for 10 x 10 Householder * V1 = V( 1 ) T1 = TAU*V1 V2 = V( 2 ) T2 = TAU*V2 V3 = V( 3 ) T3 = TAU*V3 V4 = V( 4 ) T4 = TAU*V4 V5 = V( 5 ) T5 = TAU*V5 V6 = V( 6 ) T6 = TAU*V6 V7 = V( 7 ) T7 = TAU*V7 V8 = V( 8 ) T8 = TAU*V8 V9 = V( 9 ) T9 = TAU*V9 V10 = V( 10 ) T10 = TAU*V10 DO 400 J = 1, M SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) + $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) + $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) + $ V10*C( J, 10 ) C( J, 1 ) = C( J, 1 ) - SUM*T1 C( J, 2 ) = C( J, 2 ) - SUM*T2 C( J, 3 ) = C( J, 3 ) - SUM*T3 C( J, 4 ) = C( J, 4 ) - SUM*T4 C( J, 5 ) = C( J, 5 ) - SUM*T5 C( J, 6 ) = C( J, 6 ) - SUM*T6 C( J, 7 ) = C( J, 7 ) - SUM*T7 C( J, 8 ) = C( J, 8 ) - SUM*T8 C( J, 9 ) = C( J, 9 ) - SUM*T9 C( J, 10 ) = C( J, 10 ) - SUM*T10 400 CONTINUE GO TO 410 END IF 410 RETURN * * End of SLARFX * END arpack-akloeckner-07/LAPACK/slarnd.f0000644000175000017500000000437706153460173017100 0ustar andreasandreas REAL FUNCTION SLARND( IDIST, ISEED ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST * .. * .. Array Arguments .. INTEGER ISEED( 4 ) * .. * * Purpose * ======= * * SLARND returns a random real number from a uniform or normal * distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: uniform (0,1) * = 2: uniform (-1,1) * = 3: normal (0,1) * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * Further Details * =============== * * This routine calls the auxiliary routine SLARAN to generate a random * real number from a uniform (0,1) distribution. The Box-Muller method * is used to transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. REAL ONE, TWO PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. REAL T1, T2 * .. * .. External Functions .. REAL SLARAN EXTERNAL SLARAN * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, SQRT * .. * .. Executable Statements .. * * Generate a real random number from a uniform (0,1) distribution * T1 = SLARAN( ISEED ) * IF( IDIST.EQ.1 ) THEN * * uniform (0,1) * SLARND = T1 ELSE IF( IDIST.EQ.2 ) THEN * * uniform (-1,1) * SLARND = TWO*T1 - ONE ELSE IF( IDIST.EQ.3 ) THEN * * normal (0,1) * T2 = SLARAN( ISEED ) SLARND = SQRT( -TWO*LOG( T1 ) )*COS( TWOPI*T2 ) END IF RETURN * * End of SLARND * END arpack-akloeckner-07/LAPACK/slarnv.f0000644000175000017500000000623506153460173017115 0ustar andreasandreas SUBROUTINE SLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL X( * ) * .. * * Purpose * ======= * * SLARNV returns a vector of n random real numbers from a uniform or * normal distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: uniform (0,1) * = 2: uniform (-1,1) * = 3: normal (0,1) * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * N (input) INTEGER * The number of random numbers to be generated. * * X (output) REAL array, dimension (N) * The generated random numbers. * * Further Details * =============== * * This routine calls the auxiliary routine SLARUV to generate random * real numbers from a uniform (0,1) distribution, in batches of up to * 128 using vectorisable code. The Box-Muller method is used to * transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. REAL ONE, TWO PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 ) INTEGER LV PARAMETER ( LV = 128 ) REAL TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IL2, IV * .. * .. Local Arrays .. REAL U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC COS, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL SLARUV * .. * .. Executable Statements .. * DO 40 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) IF( IDIST.EQ.3 ) THEN IL2 = 2*IL ELSE IL2 = IL END IF * * Call SLARUV to generate IL2 numbers from a uniform (0,1) * distribution (IL2 <= LV) * CALL SLARUV( ISEED, IL2, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = U( I ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = TWO*U( I ) - ONE 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ COS( TWOPI*U( 2*I ) ) 30 CONTINUE END IF 40 CONTINUE RETURN * * End of SLARNV * END arpack-akloeckner-07/LAPACK/slartg.f0000644000175000017500000000750506153460173017105 0ustar andreasandreas SUBROUTINE SLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. REAL CS, F, G, R, SN * .. * * Purpose * ======= * * SLARTG generate a plane rotation so that * * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. * [ -SN CS ] [ G ] [ 0 ] * * This is a slower, more accurate version of the BLAS1 routine SROTG, * with the following other differences: * F and G are unchanged on return. * If G=0, then CS=1 and SN=0. * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any * floating point operations (saves work in SBDSQR when * there are zeros on the diagonal). * * If F exceeds G in magnitude, CS will be positive. * * Arguments * ========= * * F (input) REAL * The first component of vector to be rotated. * * G (input) REAL * The second component of vector to be rotated. * * CS (output) REAL * The cosine of the rotation. * * SN (output) REAL * The sine of the rotation. * * R (output) REAL * The nonzero component of the rotated vector. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E0 ) REAL ONE PARAMETER ( ONE = 1.0E0 ) REAL TWO PARAMETER ( TWO = 2.0E0 ) * .. * .. Local Scalars .. LOGICAL FIRST INTEGER COUNT, I REAL EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE * .. * .. External Functions .. REAL SLAMCH EXTERNAL SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, SQRT * .. * .. Save statement .. SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 * .. * .. Data statements .. DATA FIRST / .TRUE. / * .. * .. Executable Statements .. * IF( FIRST ) THEN FIRST = .FALSE. SAFMIN = SLAMCH( 'S' ) EPS = SLAMCH( 'E' ) SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / $ LOG( SLAMCH( 'B' ) ) / TWO ) SAFMX2 = ONE / SAFMN2 END IF IF( G.EQ.ZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.ZERO ) THEN CS = ZERO SN = ONE R = G ELSE F1 = F G1 = G SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) THEN COUNT = 0 10 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMN2 G1 = G1*SAFMN2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.GE.SAFMX2 ) $ GO TO 10 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 20 I = 1, COUNT R = R*SAFMX2 20 CONTINUE ELSE IF( SCALE.LE.SAFMN2 ) THEN COUNT = 0 30 CONTINUE COUNT = COUNT + 1 F1 = F1*SAFMX2 G1 = G1*SAFMX2 SCALE = MAX( ABS( F1 ), ABS( G1 ) ) IF( SCALE.LE.SAFMN2 ) $ GO TO 30 R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R DO 40 I = 1, COUNT R = R*SAFMN2 40 CONTINUE ELSE R = SQRT( F1**2+G1**2 ) CS = F1 / R SN = G1 / R END IF IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN CS = -CS SN = -SN R = -R END IF END IF RETURN * * End of SLARTG * END arpack-akloeckner-07/LAPACK/slaruv.f0000644000175000017500000003767306153460173017136 0ustar andreasandreas SUBROUTINE SLARUV( ISEED, N, X ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) REAL X( N ) * .. * * Purpose * ======= * * SLARUV returns a vector of n random real numbers from a uniform (0,1) * distribution (n <= 128). * * This is an auxiliary routine called by SLARNV and CLARNV. * * Arguments * ========= * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * N (input) INTEGER * The number of random numbers to be generated. N <= 128. * * X (output) REAL array, dimension (N) * The generated random numbers. * * Further Details * =============== * * This routine uses a multiplicative congruential method with modulus * 2**48 and multiplier 33952834046453 (see G.S.Fishman, * 'Multiplicative congruential random number generators with modulus * 2**b: an exhaustive analysis for b = 32 and a partial analysis for * b = 48', Math. Comp. 189, pp 331-344, 1990). * * 48-bit integers are stored in 4 integer array elements with 12 bits * per element. Hence the routine is portable across machines with * integers of 32 bits or more. * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E0 ) INTEGER LV, IPW2 REAL R PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J * .. * .. Local Arrays .. INTEGER MM( LV, 4 ) * .. * .. Intrinsic Functions .. INTRINSIC MIN, MOD, REAL * .. * .. Data statements .. DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, $ 2549 / DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, $ 1145 / DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, $ 2253 / DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, $ 305 / DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, $ 3301 / DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, $ 1065 / DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, $ 3133 / DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, $ 2913 / DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, $ 3285 / DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, $ 1241 / DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, $ 1197 / DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, $ 3729 / DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, $ 2501 / DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, $ 1673 / DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, $ 541 / DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, $ 2753 / DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, $ 949 / DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, $ 2361 / DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, $ 1165 / DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, $ 4081 / DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, $ 2725 / DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, $ 3305 / DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, $ 3069 / DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, $ 3617 / DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, $ 3733 / DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, $ 409 / DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, $ 2157 / DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, $ 1361 / DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, $ 3973 / DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, $ 1865 / DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, $ 2525 / DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, $ 1409 / DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, $ 3445 / DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, $ 3577 / DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, $ 77 / DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, $ 3761 / DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, $ 2149 / DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, $ 1449 / DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, $ 3005 / DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, $ 225 / DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, $ 85 / DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, $ 3673 / DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, $ 3117 / DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, $ 3089 / DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, $ 1349 / DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, $ 2057 / DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, $ 413 / DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, $ 65 / DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, $ 1845 / DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, $ 697 / DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, $ 3085 / DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, $ 3441 / DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, $ 1573 / DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, $ 3689 / DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, $ 2941 / DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, $ 929 / DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, $ 533 / DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, $ 2841 / DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, $ 4077 / DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, $ 721 / DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, $ 2821 / DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, $ 2249 / DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, $ 2397 / DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, $ 2817 / DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, $ 245 / DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, $ 1913 / DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, $ 1997 / DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, $ 3121 / DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, $ 997 / DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, $ 1833 / DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, $ 2877 / DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, $ 1633 / DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, $ 981 / DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, $ 2009 / DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, $ 941 / DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, $ 2449 / DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, $ 197 / DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, $ 2441 / DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, $ 285 / DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, $ 1473 / DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, $ 2741 / DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, $ 3129 / DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, $ 909 / DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, $ 2801 / DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, $ 421 / DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, $ 4073 / DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, $ 2813 / DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, $ 2337 / DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, $ 1429 / DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, $ 1177 / DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, $ 1901 / DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, $ 81 / DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, $ 1669 / DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, $ 2633 / DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, $ 2269 / DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, $ 129 / DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, $ 1141 / DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, $ 249 / DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, $ 3917 / DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, $ 2481 / DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, $ 3941 / DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, $ 2217 / DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, $ 2749 / DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, $ 3041 / DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, $ 1877 / DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, $ 345 / DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, $ 2861 / DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, $ 1809 / DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, $ 3141 / DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, $ 2825 / DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, $ 157 / DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, $ 2881 / DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, $ 3637 / DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, $ 1465 / DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, $ 2829 / DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, $ 2161 / DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, $ 3365 / DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, $ 361 / DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, $ 2685 / DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, $ 3745 / DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, $ 2325 / DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, $ 3609 / DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, $ 3821 / DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, $ 3537 / DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, $ 517 / DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, $ 3017 / DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, $ 2141 / DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, $ 1537 / * .. * .. Executable Statements .. * I1 = ISEED( 1 ) I2 = ISEED( 2 ) I3 = ISEED( 3 ) I4 = ISEED( 4 ) * DO 10 I = 1, MIN( N, LV ) * * Multiply the seed by i-th power of the multiplier modulo 2**48 * IT4 = I4*MM( I, 4 ) IT3 = IT4 / IPW2 IT4 = IT4 - IPW2*IT3 IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) IT2 = IT3 / IPW2 IT3 = IT3 - IPW2*IT2 IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) IT1 = IT2 / IPW2 IT2 = IT2 - IPW2*IT1 IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + $ I4*MM( I, 1 ) IT1 = MOD( IT1, IPW2 ) * * Convert 48-bit integer to a real number in the interval (0,1) * X( I ) = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R* $ REAL( IT4 ) ) ) ) 10 CONTINUE * * Return final value of seed * ISEED( 1 ) = IT1 ISEED( 2 ) = IT2 ISEED( 3 ) = IT3 ISEED( 4 ) = IT4 RETURN * * End of SLARUV * END arpack-akloeckner-07/LAPACK/slascl.f0000644000175000017500000001616406153460173017073 0ustar andreasandreas SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N REAL CFROM, CTO * .. * .. Array Arguments .. REAL A( LDA, * ) * .. * * Purpose * ======= * * SLASCL multiplies the M by N real matrix A by the real scalar * CTO/CFROM. This is done without over/underflow as long as the final * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that * A may be full, upper triangular, lower triangular, upper Hessenberg, * or banded. * * Arguments * ========= * * TYPE (input) CHARACTER*1 * TYPE indices the storage type of the input matrix. * = 'G': A is a full matrix. * = 'L': A is a lower triangular matrix. * = 'U': A is an upper triangular matrix. * = 'H': A is an upper Hessenberg matrix. * = 'B': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the lower * half stored. * = 'Q': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the upper * half stored. * = 'Z': A is a band matrix with lower bandwidth KL and upper * bandwidth KU. * * KL (input) INTEGER * The lower bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * KU (input) INTEGER * The upper bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * CFROM (input) REAL * CTO (input) REAL * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed * without over/underflow if the final result CTO*A(I,J)/CFROM * can be represented without over/underflow. CFROM must be * nonzero. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) REAL array, dimension (LDA,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * INFO (output) INTEGER * 0 - successful exit * <0 - if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH EXTERNAL LSAME, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of SLASCL * END arpack-akloeckner-07/LAPACK/slaset.f0000644000175000017500000000614706153460174017106 0ustar andreasandreas SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N REAL ALPHA, BETA * .. * .. Array Arguments .. REAL A( LDA, * ) * .. * * Purpose * ======= * * SLASET initializes an m-by-n matrix A to BETA on the diagonal and * ALPHA on the offdiagonals. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be set. * = 'U': Upper triangular part is set; the strictly lower * triangular part of A is not changed. * = 'L': Lower triangular part is set; the strictly upper * triangular part of A is not changed. * Otherwise: All of the matrix A is set. * * 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. * * ALPHA (input) REAL * The constant to which the offdiagonal elements are to be set. * * BETA (input) REAL * The constant to which the diagonal elements are to be set. * * A (input/output) REAL array, dimension (LDA,N) * On exit, the leading m-by-n submatrix of A is set as follows: * * if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, * if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, * otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, * * and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the strictly upper triangular or trapezoidal part of the * array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the strictly lower triangular or trapezoidal part of the * array to ALPHA. * DO 40 J = 1, MIN( M, N ) DO 30 I = J + 1, M A( I, J ) = ALPHA 30 CONTINUE 40 CONTINUE * ELSE * * Set the leading m-by-n submatrix to ALPHA. * DO 60 J = 1, N DO 50 I = 1, M A( I, J ) = ALPHA 50 CONTINUE 60 CONTINUE END IF * * Set the first min(M,N) diagonal elements to BETA. * DO 70 I = 1, MIN( M, N ) A( I, I ) = BETA 70 CONTINUE * RETURN * * End of SLASET * END arpack-akloeckner-07/LAPACK/slasr.f0000644000175000017500000002634306153460174016737 0ustar andreasandreas SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER DIRECT, PIVOT, SIDE INTEGER LDA, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( * ), S( * ) * .. * * Purpose * ======= * * SLASR performs the transformation * * A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) * * A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) * * where A is an m by n real matrix and P is an orthogonal matrix, * consisting of a sequence of plane rotations determined by the * parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' * and z = n when SIDE = 'R' or 'r' ): * * When DIRECT = 'F' or 'f' ( Forward sequence ) then * * P = P( z - 1 )*...*P( 2 )*P( 1 ), * * and when DIRECT = 'B' or 'b' ( Backward sequence ) then * * P = P( 1 )*P( 2 )*...*P( z - 1 ), * * where P( k ) is a plane rotation matrix for the following planes: * * when PIVOT = 'V' or 'v' ( Variable pivot ), * the plane ( k, k + 1 ) * * when PIVOT = 'T' or 't' ( Top pivot ), * the plane ( 1, k + 1 ) * * when PIVOT = 'B' or 'b' ( Bottom pivot ), * the plane ( k, z ) * * c( k ) and s( k ) must contain the cosine and sine that define the * matrix P( k ). The two by two plane rotation part of the matrix * P( k ), R( k ), is assumed to be of the form * * R( k ) = ( c( k ) s( k ) ). * ( -s( k ) c( k ) ) * * This version vectorises across rows of the array A when SIDE = 'L'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * Specifies whether the plane rotation matrix P is applied to * A on the left or the right. * = 'L': Left, compute A := P*A * = 'R': Right, compute A:= A*P' * * DIRECT (input) CHARACTER*1 * Specifies whether P is a forward or backward sequence of * plane rotations. * = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) * = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) * * PIVOT (input) CHARACTER*1 * Specifies the plane for which P(k) is a plane rotation * matrix. * = 'V': Variable pivot, the plane (k,k+1) * = 'T': Top pivot, the plane (1,k+1) * = 'B': Bottom pivot, the plane (k,z) * * M (input) INTEGER * The number of rows of the matrix A. If m <= 1, an immediate * return is effected. * * N (input) INTEGER * The number of columns of the matrix A. If n <= 1, an * immediate return is effected. * * C, S (input) REAL arrays, dimension * (M-1) if SIDE = 'L' * (N-1) if SIDE = 'R' * c(k) and s(k) contain the cosine and sine that define the * matrix P(k). The two by two plane rotation part of the * matrix P(k), R(k), is assumed to be of the form * R( k ) = ( c( k ) s( k ) ). * ( -s( k ) c( k ) ) * * A (input/output) REAL array, dimension (LDA,N) * The m by n matrix A. On exit, A is overwritten by P*A if * SIDE = 'R' or by A*P' if SIDE = 'L'. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I, INFO, J REAL CTEMP, STEMP, 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( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN INFO = 1 ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN INFO = 2 ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) $ THEN INFO = 3 ELSE IF( M.LT.0 ) THEN INFO = 4 ELSE IF( N.LT.0 ) THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = 9 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLASR ', INFO ) RETURN END IF * * Quick return if possible * IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) $ RETURN IF( LSAME( SIDE, 'L' ) ) THEN * * Form P * A * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 20 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 10 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 10 CONTINUE END IF 20 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 40 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 30 I = 1, N TEMP = A( J+1, I ) A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) 30 CONTINUE END IF 40 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 60 J = 2, M CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 50 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 50 CONTINUE END IF 60 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 80 J = M, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 70 I = 1, N TEMP = A( J, I ) A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) 70 CONTINUE END IF 80 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 100 J = 1, M - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 90 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 90 CONTINUE END IF 100 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 120 J = M - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 110 I = 1, N TEMP = A( J, I ) A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP 110 CONTINUE END IF 120 CONTINUE END IF END IF ELSE IF( LSAME( SIDE, 'R' ) ) THEN * * Form A * P' * IF( LSAME( PIVOT, 'V' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 140 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 130 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 130 CONTINUE END IF 140 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 160 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 150 I = 1, M TEMP = A( I, J+1 ) A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) 150 CONTINUE END IF 160 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'T' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 180 J = 2, N CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 170 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 170 CONTINUE END IF 180 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 200 J = N, 2, -1 CTEMP = C( J-1 ) STEMP = S( J-1 ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 190 I = 1, M TEMP = A( I, J ) A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) 190 CONTINUE END IF 200 CONTINUE END IF ELSE IF( LSAME( PIVOT, 'B' ) ) THEN IF( LSAME( DIRECT, 'F' ) ) THEN DO 220 J = 1, N - 1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 210 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 210 CONTINUE END IF 220 CONTINUE ELSE IF( LSAME( DIRECT, 'B' ) ) THEN DO 240 J = N - 1, 1, -1 CTEMP = C( J ) STEMP = S( J ) IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN DO 230 I = 1, M TEMP = A( I, J ) A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP 230 CONTINUE END IF 240 CONTINUE END IF END IF END IF * RETURN * * End of SLASR * END arpack-akloeckner-07/LAPACK/slasrt.f0000644000175000017500000001441106153460174017114 0ustar andreasandreas SUBROUTINE SLASRT( ID, N, D, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER ID INTEGER INFO, N * .. * .. Array Arguments .. REAL D( * ) * .. * * Purpose * ======= * * Sort the numbers in D in increasing order (if ID = 'I') or * in decreasing order (if ID = 'D' ). * * Use Quick Sort, reverting to Insertion sort on arrays of * size <= 20. Dimension of STACK limits N to about 2**32. * * Arguments * ========= * * ID (input) CHARACTER*1 * = 'I': sort D in increasing order; * = 'D': sort D in decreasing order. * * N (input) INTEGER * The length of the array D. * * D (input/output) REAL array, dimension (N) * On entry, the array to be sorted. * On exit, D has been sorted into increasing order * (D(1) <= ... <= D(N) ) or into decreasing order * (D(1) >= ... >= D(N) ), depending on ID. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. INTEGER SELECT PARAMETER ( SELECT = 20 ) * .. * .. Local Scalars .. INTEGER DIR, ENDD, I, J, START, STKPNT REAL D1, D2, D3, DMNMX, TMP * .. * .. Local Arrays .. INTEGER STACK( 2, 32 ) * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input paramters. * INFO = 0 DIR = -1 IF( LSAME( ID, 'D' ) ) THEN DIR = 0 ELSE IF( LSAME( ID, 'I' ) ) THEN DIR = 1 END IF IF( DIR.EQ.-1 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SLASRT', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * STKPNT = 1 STACK( 1, 1 ) = 1 STACK( 2, 1 ) = N 10 CONTINUE START = STACK( 1, STKPNT ) ENDD = STACK( 2, STKPNT ) STKPNT = STKPNT - 1 IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN * * Do Insertion sort on D( START:ENDD ) * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * DO 30 I = START + 1, ENDD DO 20 J = I, START + 1, -1 IF( D( J ).GT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 30 END IF 20 CONTINUE 30 CONTINUE * ELSE * * Sort into increasing order * DO 50 I = START + 1, ENDD DO 40 J = I, START + 1, -1 IF( D( J ).LT.D( J-1 ) ) THEN DMNMX = D( J ) D( J ) = D( J-1 ) D( J-1 ) = DMNMX ELSE GO TO 50 END IF 40 CONTINUE 50 CONTINUE * END IF * ELSE IF( ENDD-START.GT.SELECT ) THEN * * Partition D( START:ENDD ) and stack parts, largest one first * * Choose partition entry as median of 3 * D1 = D( START ) D2 = D( ENDD ) I = ( START+ENDD ) / 2 D3 = D( I ) IF( D1.LT.D2 ) THEN IF( D3.LT.D1 ) THEN DMNMX = D1 ELSE IF( D3.LT.D2 ) THEN DMNMX = D3 ELSE DMNMX = D2 END IF ELSE IF( D3.LT.D2 ) THEN DMNMX = D2 ELSE IF( D3.LT.D1 ) THEN DMNMX = D3 ELSE DMNMX = D1 END IF END IF * IF( DIR.EQ.0 ) THEN * * Sort into decreasing order * I = START - 1 J = ENDD + 1 60 CONTINUE 70 CONTINUE J = J - 1 IF( D( J ).LT.DMNMX ) $ GO TO 70 80 CONTINUE I = I + 1 IF( D( I ).GT.DMNMX ) $ GO TO 80 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 60 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF ELSE * * Sort into increasing order * I = START - 1 J = ENDD + 1 90 CONTINUE 100 CONTINUE J = J - 1 IF( D( J ).GT.DMNMX ) $ GO TO 100 110 CONTINUE I = I + 1 IF( D( I ).LT.DMNMX ) $ GO TO 110 IF( I.LT.J ) THEN TMP = D( I ) D( I ) = D( J ) D( J ) = TMP GO TO 90 END IF IF( J-START.GT.ENDD-J-1 ) THEN STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD ELSE STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = J + 1 STACK( 2, STKPNT ) = ENDD STKPNT = STKPNT + 1 STACK( 1, STKPNT ) = START STACK( 2, STKPNT ) = J END IF END IF END IF IF( STKPNT.GT.0 ) $ GO TO 10 RETURN * * End of SLASRT * END arpack-akloeckner-07/LAPACK/slassq.f0000644000175000017500000000510206153460174017107 0ustar andreasandreas SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N REAL SCALE, SUMSQ * .. * .. Array Arguments .. REAL X( * ) * .. * * Purpose * ======= * * SLASSQ returns the values scl and smsq such that * * ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, * * where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is * assumed to be non-negative and scl returns the value * * scl = max( scale, abs( x( i ) ) ). * * scale and sumsq must be supplied in SCALE and SUMSQ and * scl and smsq are overwritten on SCALE and SUMSQ respectively. * * The routine makes only one pass through the vector x. * * Arguments * ========= * * N (input) INTEGER * The number of elements to be used from the vector X. * * X (input) REAL * The vector for which a scaled sum of squares is computed. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. * * INCX (input) INTEGER * The increment between successive values of the vector X. * INCX > 0. * * SCALE (input/output) REAL * On entry, the value scale in the equation above. * On exit, SCALE is overwritten with scl , the scaling factor * for the sum of squares. * * SUMSQ (input/output) REAL * On entry, the value sumsq in the equation above. * On exit, SUMSQ is overwritten with smsq , the basic sum of * squares from which scl has been factored out. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER IX REAL ABSXI * .. * .. Intrinsic Functions .. INTRINSIC ABS * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( X( IX ).NE.ZERO ) THEN ABSXI = ABS( X( IX ) ) IF( SCALE.LT.ABSXI ) THEN SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 SCALE = ABSXI ELSE SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 END IF END IF 10 CONTINUE END IF RETURN * * End of SLASSQ * END arpack-akloeckner-07/LAPACK/slaswp.f0000644000175000017500000000541506153460174017121 0ustar andreasandreas SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) REAL A( LDA, * ) * .. * * Purpose * ======= * * SLASWP performs a series of row interchanges on the matrix A. * One row interchange is initiated for each of rows K1 through K2 of A. * * Arguments * ========= * * N (input) INTEGER * The number of columns of the matrix A. * * A (input/output) REAL array, dimension (LDA,N) * On entry, the matrix of column dimension N to which the row * interchanges will be applied. * On exit, the permuted matrix. * * LDA (input) INTEGER * The leading dimension of the array A. * * K1 (input) INTEGER * The first element of IPIV for which a row interchange will * be done. * * K2 (input) INTEGER * The last element of IPIV for which a row interchange will * be done. * * IPIV (input) INTEGER array, dimension (M*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. * * INCX (input) INTEGER * The increment between successive values of IPIV. If IPIV * is negative, the pivots are applied in reverse order. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IP, IX * .. * .. External Subroutines .. EXTERNAL SSWAP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.EQ.0 ) $ RETURN IF( INCX.GT.0 ) THEN IX = K1 ELSE IX = 1 + ( 1-K2 )*INCX END IF IF( INCX.EQ.1 ) THEN DO 10 I = K1, K2 IP = IPIV( I ) IF( IP.NE.I ) $ CALL SSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) 10 CONTINUE ELSE IF( INCX.GT.1 ) THEN DO 20 I = K1, K2 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL SSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 20 CONTINUE ELSE IF( INCX.LT.0 ) THEN DO 30 I = K2, K1, -1 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL SSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 30 CONTINUE END IF * RETURN * * End of SLASWP * END arpack-akloeckner-07/LAPACK/zlarf.f0000644000175000017500000000626706153460177016737 0ustar andreasandreas SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE INTEGER INCV, LDC, M, N COMPLEX*16 TAU * .. * .. Array Arguments .. COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) * .. * * Purpose * ======= * * ZLARF applies a complex elementary reflector H to a complex M-by-N * matrix C, from either the left or the right. H is represented in the * form * * H = I - tau * v * v' * * where tau is a complex scalar and v is a complex vector. * * If tau = 0, then H is taken to be the unit matrix. * * To apply H' (the conjugate transpose of H), supply conjg(tau) instead * tau. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': form H * C * = 'R': form C * H * * M (input) INTEGER * The number of rows of the matrix C. * * N (input) INTEGER * The number of columns of the matrix C. * * V (input) COMPLEX*16 array, dimension * (1 + (M-1)*abs(INCV)) if SIDE = 'L' * or (1 + (N-1)*abs(INCV)) if SIDE = 'R' * The vector v in the representation of H. V is not used if * TAU = 0. * * INCV (input) INTEGER * The increment between elements of v. INCV <> 0. * * TAU (input) COMPLEX*16 * The value tau in the representation of H. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N matrix C. * On exit, C is overwritten by the matrix H * C if SIDE = 'L', * or C * H if SIDE = 'R'. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L' * or (M) if SIDE = 'R' * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. External Subroutines .. EXTERNAL ZGEMV, ZGERC * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Executable Statements .. * IF( LSAME( SIDE, 'L' ) ) THEN * * Form H * C * IF( TAU.NE.ZERO ) THEN * * w := C' * v * CALL ZGEMV( 'Conjugate transpose', M, N, ONE, C, LDC, V, $ INCV, ZERO, WORK, 1 ) * * C := C - v * w' * CALL ZGERC( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) END IF ELSE * * Form C * H * IF( TAU.NE.ZERO ) THEN * * w := C * v * CALL ZGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, $ ZERO, WORK, 1 ) * * C := C - w * v' * CALL ZGERC( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) END IF END IF RETURN * * End of ZLARF * END arpack-akloeckner-07/LAPACK/slasy2.f0000644000175000017500000002750206153460174017026 0ustar andreasandreas SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. LOGICAL LTRANL, LTRANR INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 REAL SCALE, XNORM * .. * .. Array Arguments .. REAL B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), $ X( LDX, * ) * .. * * Purpose * ======= * * SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in * * op(TL)*X + ISGN*X*op(TR) = SCALE*B, * * where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or * -1. op(T) = T or T', where T' denotes the transpose of T. * * Arguments * ========= * * LTRANL (input) LOGICAL * On entry, LTRANL specifies the op(TL): * = .FALSE., op(TL) = TL, * = .TRUE., op(TL) = TL'. * * LTRANR (input) LOGICAL * On entry, LTRANR specifies the op(TR): * = .FALSE., op(TR) = TR, * = .TRUE., op(TR) = TR'. * * ISGN (input) INTEGER * On entry, ISGN specifies the sign of the equation * as described before. ISGN may only be 1 or -1. * * N1 (input) INTEGER * On entry, N1 specifies the order of matrix TL. * N1 may only be 0, 1 or 2. * * N2 (input) INTEGER * On entry, N2 specifies the order of matrix TR. * N2 may only be 0, 1 or 2. * * TL (input) REAL array, dimension (LDTL,2) * On entry, TL contains an N1 by N1 matrix. * * LDTL (input) INTEGER * The leading dimension of the matrix TL. LDTL >= max(1,N1). * * TR (input) REAL array, dimension (LDTR,2) * On entry, TR contains an N2 by N2 matrix. * * LDTR (input) INTEGER * The leading dimension of the matrix TR. LDTR >= max(1,N2). * * B (input) REAL array, dimension (LDB,2) * On entry, the N1 by N2 matrix B contains the right-hand * side of the equation. * * LDB (input) INTEGER * The leading dimension of the matrix B. LDB >= max(1,N1). * * SCALE (output) REAL * On exit, SCALE contains the scale factor. SCALE is chosen * less than or equal to 1 to prevent the solution overflowing. * * X (output) REAL array, dimension (LDX,2) * On exit, X contains the N1 by N2 solution. * * LDX (input) INTEGER * The leading dimension of the matrix X. LDX >= max(1,N1). * * XNORM (output) REAL * On exit, XNORM is the infinity-norm of the solution. * * INFO (output) INTEGER * On exit, INFO is set to * 0: successful exit. * 1: TL and TR have too close eigenvalues, so TL or * TR is perturbed to get a nonsingular equation. * NOTE: In the interests of speed, this routine does not * check the inputs for errors. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) REAL TWO, HALF, EIGHT PARAMETER ( TWO = 2.0E+0, HALF = 0.5E+0, EIGHT = 8.0E+0 ) * .. * .. Local Scalars .. LOGICAL BSWAP, XSWAP INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K REAL BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, $ TEMP, U11, U12, U22, XMAX * .. * .. Local Arrays .. LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), $ LOCU22( 4 ) REAL BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) * .. * .. External Functions .. INTEGER ISAMAX REAL SLAMCH EXTERNAL ISAMAX, SLAMCH * .. * .. External Subroutines .. EXTERNAL SCOPY, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX * .. * .. Data statements .. DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , $ LOCU22 / 4, 3, 2, 1 / DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / * .. * .. Executable Statements .. * * Do not check the input parameters for errors * INFO = 0 * * Quick return if possible * IF( N1.EQ.0 .OR. N2.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) / EPS SGN = ISGN * K = N1 + N1 + N2 - 2 GO TO ( 10, 20, 30, 50 )K * * 1 by 1: TL11*X + SGN*X*TR11 = B11 * 10 CONTINUE TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 ) BET = ABS( TAU1 ) IF( BET.LE.SMLNUM ) THEN TAU1 = SMLNUM BET = SMLNUM INFO = 1 END IF * SCALE = ONE GAM = ABS( B( 1, 1 ) ) IF( SMLNUM*GAM.GT.BET ) $ SCALE = ONE / GAM * X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 XNORM = ABS( X( 1, 1 ) ) RETURN * * 1 by 2: * TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] * [TR21 TR22] * 20 CONTINUE * SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ), $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) IF( LTRANR ) THEN TMP( 2 ) = SGN*TR( 2, 1 ) TMP( 3 ) = SGN*TR( 1, 2 ) ELSE TMP( 2 ) = SGN*TR( 1, 2 ) TMP( 3 ) = SGN*TR( 2, 1 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 1, 2 ) GO TO 40 * * 2 by 1: * op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] * [TL21 TL22] [X21] [X21] [B21] * 30 CONTINUE SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ), $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ), $ SMLNUM ) TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) IF( LTRANL ) THEN TMP( 2 ) = TL( 1, 2 ) TMP( 3 ) = TL( 2, 1 ) ELSE TMP( 2 ) = TL( 2, 1 ) TMP( 3 ) = TL( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) 40 CONTINUE * * Solve 2 by 2 system using complete pivoting. * Set pivots less than SMIN to SMIN. * IPIV = ISAMAX( 4, TMP, 1 ) U11 = TMP( IPIV ) IF( ABS( U11 ).LE.SMIN ) THEN INFO = 1 U11 = SMIN END IF U12 = TMP( LOCU12( IPIV ) ) L21 = TMP( LOCL21( IPIV ) ) / U11 U22 = TMP( LOCU22( IPIV ) ) - U12*L21 XSWAP = XSWPIV( IPIV ) BSWAP = BSWPIV( IPIV ) IF( ABS( U22 ).LE.SMIN ) THEN INFO = 1 U22 = SMIN END IF IF( BSWAP ) THEN TEMP = BTMP( 2 ) BTMP( 2 ) = BTMP( 1 ) - L21*TEMP BTMP( 1 ) = TEMP ELSE BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) END IF SCALE = ONE IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE END IF X2( 2 ) = BTMP( 2 ) / U22 X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) IF( XSWAP ) THEN TEMP = X2( 2 ) X2( 2 ) = X2( 1 ) X2( 1 ) = TEMP END IF X( 1, 1 ) = X2( 1 ) IF( N1.EQ.1 ) THEN X( 1, 2 ) = X2( 2 ) XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) ) ELSE X( 2, 1 ) = X2( 2 ) XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) END IF RETURN * * 2 by 2: * op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] * [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] * * Solve equivalent 4 by 4 system using complete pivoting. * Set pivots less than SMIN to SMIN. * 50 CONTINUE SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) SMIN = MAX( EPS*SMIN, SMLNUM ) BTMP( 1 ) = ZERO CALL SCOPY( 16, BTMP, 0, T16, 1 ) T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 ) T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 ) T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 ) T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 ) IF( LTRANL ) THEN T16( 1, 2 ) = TL( 2, 1 ) T16( 2, 1 ) = TL( 1, 2 ) T16( 3, 4 ) = TL( 2, 1 ) T16( 4, 3 ) = TL( 1, 2 ) ELSE T16( 1, 2 ) = TL( 1, 2 ) T16( 2, 1 ) = TL( 2, 1 ) T16( 3, 4 ) = TL( 1, 2 ) T16( 4, 3 ) = TL( 2, 1 ) END IF IF( LTRANR ) THEN T16( 1, 3 ) = SGN*TR( 1, 2 ) T16( 2, 4 ) = SGN*TR( 1, 2 ) T16( 3, 1 ) = SGN*TR( 2, 1 ) T16( 4, 2 ) = SGN*TR( 2, 1 ) ELSE T16( 1, 3 ) = SGN*TR( 2, 1 ) T16( 2, 4 ) = SGN*TR( 2, 1 ) T16( 3, 1 ) = SGN*TR( 1, 2 ) T16( 4, 2 ) = SGN*TR( 1, 2 ) END IF BTMP( 1 ) = B( 1, 1 ) BTMP( 2 ) = B( 2, 1 ) BTMP( 3 ) = B( 1, 2 ) BTMP( 4 ) = B( 2, 2 ) * * Perform elimination * DO 100 I = 1, 3 XMAX = ZERO DO 70 IP = I, 4 DO 60 JP = I, 4 IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN XMAX = ABS( T16( IP, JP ) ) IPSV = IP JPSV = JP END IF 60 CONTINUE 70 CONTINUE IF( IPSV.NE.I ) THEN CALL SSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) TEMP = BTMP( I ) BTMP( I ) = BTMP( IPSV ) BTMP( IPSV ) = TEMP END IF IF( JPSV.NE.I ) $ CALL SSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) JPIV( I ) = JPSV IF( ABS( T16( I, I ) ).LT.SMIN ) THEN INFO = 1 T16( I, I ) = SMIN END IF DO 90 J = I + 1, 4 T16( J, I ) = T16( J, I ) / T16( I, I ) BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) DO 80 K = I + 1, 4 T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) 80 CONTINUE 90 CONTINUE 100 CONTINUE IF( ABS( T16( 4, 4 ) ).LT.SMIN ) $ T16( 4, 4 ) = SMIN SCALE = ONE IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) ) BTMP( 1 ) = BTMP( 1 )*SCALE BTMP( 2 ) = BTMP( 2 )*SCALE BTMP( 3 ) = BTMP( 3 )*SCALE BTMP( 4 ) = BTMP( 4 )*SCALE END IF DO 120 I = 1, 4 K = 5 - I TEMP = ONE / T16( K, K ) TMP( K ) = BTMP( K )*TEMP DO 110 J = K + 1, 4 TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) 110 CONTINUE 120 CONTINUE DO 130 I = 1, 3 IF( JPIV( 4-I ).NE.4-I ) THEN TEMP = TMP( 4-I ) TMP( 4-I ) = TMP( JPIV( 4-I ) ) TMP( JPIV( 4-I ) ) = TEMP END IF 130 CONTINUE X( 1, 1 ) = TMP( 1 ) X( 2, 1 ) = TMP( 2 ) X( 1, 2 ) = TMP( 3 ) X( 2, 2 ) = TMP( 4 ) XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ), $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) ) RETURN * * End of SLASY2 * END arpack-akloeckner-07/LAPACK/sorm2r.f0000644000175000017500000001216606153460174017035 0ustar andreasandreas SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * SORM2R overwrites the general real m by n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'T', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'T', * * where Q is a real orthogonal matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'T': apply Q' (Transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) REAL array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * SGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) REAL array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by SGEQRF. * * C (input/output) REAL array, dimension (LDC,N) * On entry, the m by n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) REAL array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. REAL ONE PARAMETER ( ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLARF, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, '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 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SORM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) $ THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) * AII = A( I, I ) A( I, I ) = ONE CALL SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), $ LDC, WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of SORM2R * END arpack-akloeckner-07/LAPACK/spttrf.f0000644000175000017500000000577506153460174017143 0ustar andreasandreas SUBROUTINE SPTTRF( N, D, E, INFO ) * * -- LAPACK routine (version 2.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, N * .. * .. Array Arguments .. REAL D( * ), E( * ) * .. * * Purpose * ======= * * SPTTRF computes the factorization of a real symmetric positive * definite tridiagonal matrix A. * * If the subdiagonal elements of A are supplied in the array E, the * factorization has the form A = L*D*L**T, where D is diagonal and L * is unit lower bidiagonal; if the superdiagonal elements of A are * supplied, it has the form A = U**T*D*U, where U is unit upper * bidiagonal. (The two forms are equivalent if A is real.) * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * D (input/output) REAL array, dimension (N) * On entry, the n diagonal elements of the tridiagonal matrix * A. On exit, the n diagonal elements of the diagonal matrix * D from the L*D*L**T factorization of A. * * E (input/output) REAL array, dimension (N-1) * On entry, the (n-1) off-diagonal elements of the tridiagonal * matrix A. * On exit, the (n-1) off-diagonal elements of the unit * bidiagonal factor L or U from the factorization of A. * * 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; if i < N, the factorization could * not be completed, while if i = N, the factorization was * completed, but D(N) = 0. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. INTEGER I REAL DI, EI * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'SPTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Compute the L*D*L' (or U'*D*U) factorization of A. * DO 10 I = 1, N - 1 * * Drop out of the loop if d(i) <= 0: the matrix is not positive * definite. * DI = D( I ) IF( DI.LE.ZERO ) $ GO TO 20 * * Solve for e(i) and d(i+1). * EI = E( I ) E( I ) = EI / DI D( I+1 ) = D( I+1 ) - E( I )*EI 10 CONTINUE * * Check d(n) for positive definiteness. * I = N IF( D( I ).GT.ZERO ) $ GO TO 30 * 20 CONTINUE INFO = I * 30 CONTINUE RETURN * * End of SPTTRF * END arpack-akloeckner-07/LAPACK/spttrs.f0000644000175000017500000000553506153460174017152 0ustar andreasandreas SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO ) * * -- LAPACK routine (version 2.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, LDB, N, NRHS * .. * .. Array Arguments .. REAL B( LDB, * ), D( * ), E( * ) * .. * * Purpose * ======= * * SPTTRS solves a system of linear equations A * X = B with a * symmetric positive definite tridiagonal matrix A using the * factorization A = L*D*L**T or A = U**T*D*U computed by SPTTRF. * (The two forms are equivalent if A is real.) * * Arguments * ========= * * N (input) INTEGER * The order of the tridiagonal 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. * * D (input) REAL array, dimension (N) * The n diagonal elements of the diagonal matrix D from the * factorization computed by SPTTRF. * * E (input) REAL array, dimension (N-1) * The (n-1) off-diagonal elements of the unit bidiagonal factor * U or L from the factorization computed by SPTTRF. * * B (input/output) REAL array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input arguments. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 ELSE IF( NRHS.LT.0 ) THEN INFO = -2 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SPTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Solve A * X = B using the factorization A = L*D*L', * overwriting each right hand side vector with its solution. * DO 30 J = 1, NRHS * * Solve L * x = b. * DO 10 I = 2, N B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 ) 10 CONTINUE * * Solve D * L' * x = b. * B( N, J ) = B( N, J ) / D( N ) DO 20 I = N - 1, 1, -1 B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I ) 20 CONTINUE 30 CONTINUE * RETURN * * End of SPTTRS * END arpack-akloeckner-07/LAPACK/ssteqr.f0000644000175000017500000003277006153460175017136 0ustar andreasandreas SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPZ INTEGER INFO, LDZ, N * .. * .. Array Arguments .. REAL D( * ), E( * ), WORK( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * SSTEQR computes all eigenvalues and, optionally, eigenvectors of a * symmetric tridiagonal matrix using the implicit QL or QR method. * The eigenvectors of a full or band symmetric matrix can also be found * if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to * tridiagonal form. * * Arguments * ========= * * COMPZ (input) CHARACTER*1 * = 'N': Compute eigenvalues only. * = 'V': Compute eigenvalues and eigenvectors of the original * symmetric matrix. On entry, Z must contain the * orthogonal matrix used to reduce the original matrix * to tridiagonal form. * = 'I': Compute eigenvalues and eigenvectors of the * tridiagonal matrix. Z is initialized to the identity * matrix. * * N (input) INTEGER * The order of the matrix. N >= 0. * * D (input/output) REAL array, dimension (N) * On entry, the diagonal elements of the tridiagonal matrix. * On exit, if INFO = 0, the eigenvalues in ascending order. * * E (input/output) REAL array, dimension (N-1) * On entry, the (n-1) subdiagonal elements of the tridiagonal * matrix. * On exit, E has been destroyed. * * Z (input/output) REAL array, dimension (LDZ, N) * On entry, if COMPZ = 'V', then Z contains the orthogonal * matrix used in the reduction to tridiagonal form. * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the * orthonormal eigenvectors of the original symmetric matrix, * and if COMPZ = 'I', Z contains the orthonormal eigenvectors * of the symmetric tridiagonal matrix. * If COMPZ = 'N', then Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= 1, and if * eigenvectors are desired, then LDZ >= max(1,N). * * WORK (workspace) REAL array, dimension (max(1,2*N-2)) * If COMPZ = 'N', then WORK is not referenced. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * > 0: the algorithm has failed to find all the eigenvalues in * a total of 30*N iterations; if INFO = i, then i * elements of E have not converged to zero; on exit, D * and E contain the elements of a symmetric tridiagonal * matrix which is orthogonally similar to the original * matrix. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE, TWO, THREE PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0, $ THREE = 3.0E0 ) INTEGER MAXIT PARAMETER ( MAXIT = 30 ) * .. * .. Local Scalars .. INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, $ NM1, NMAXIT REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST * .. * .. External Functions .. LOGICAL LSAME REAL SLAMCH, SLANST, SLAPY2 EXTERNAL LSAME, SLAMCH, SLANST, SLAPY2 * .. * .. External Subroutines .. EXTERNAL SLAE2, SLAEV2, SLARTG, SLASCL, SLASET, SLASR, $ SLASRT, SSWAP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 * IF( LSAME( COMPZ, 'N' ) ) THEN ICOMPZ = 0 ELSE IF( LSAME( COMPZ, 'V' ) ) THEN ICOMPZ = 1 ELSE IF( LSAME( COMPZ, 'I' ) ) THEN ICOMPZ = 2 ELSE ICOMPZ = -1 END IF IF( ICOMPZ.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, $ N ) ) ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'SSTEQR', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * IF( N.EQ.1 ) THEN IF( ICOMPZ.EQ.2 ) $ Z( 1, 1 ) = ONE RETURN END IF * * Determine the unit roundoff and over/underflow thresholds. * EPS = SLAMCH( 'E' ) EPS2 = EPS**2 SAFMIN = SLAMCH( 'S' ) SAFMAX = ONE / SAFMIN SSFMAX = SQRT( SAFMAX ) / THREE SSFMIN = SQRT( SAFMIN ) / EPS2 * * Compute the eigenvalues and eigenvectors of the tridiagonal * matrix. * IF( ICOMPZ.EQ.2 ) $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) * NMAXIT = N*MAXIT JTOT = 0 * * Determine where the matrix splits and choose QL or QR iteration * for each block, according to whether top or bottom diagonal * element is smaller. * L1 = 1 NM1 = N - 1 * 10 CONTINUE IF( L1.GT.N ) $ GO TO 160 IF( L1.GT.1 ) $ E( L1-1 ) = ZERO IF( L1.LE.NM1 ) THEN DO 20 M = L1, NM1 TST = ABS( E( M ) ) IF( TST.EQ.ZERO ) $ GO TO 30 IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ $ 1 ) ) ) )*EPS ) THEN E( M ) = ZERO GO TO 30 END IF 20 CONTINUE END IF M = N * 30 CONTINUE L = L1 LSV = L LEND = M LENDSV = LEND L1 = M + 1 IF( LEND.EQ.L ) $ GO TO 10 * * Scale submatrix in rows and columns L to LEND * ANORM = SLANST( 'I', LEND-L+1, D( L ), E( L ) ) ISCALE = 0 IF( ANORM.EQ.ZERO ) $ GO TO 10 IF( ANORM.GT.SSFMAX ) THEN ISCALE = 1 CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, $ INFO ) CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, $ INFO ) ELSE IF( ANORM.LT.SSFMIN ) THEN ISCALE = 2 CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, $ INFO ) CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, $ INFO ) END IF * * Choose between QL and QR iteration * IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN LEND = LSV L = LENDSV END IF * IF( LEND.GT.L ) THEN * * QL Iteration * * Look for small subdiagonal element. * 40 CONTINUE IF( L.NE.LEND ) THEN LENDM1 = LEND - 1 DO 50 M = L, LENDM1 TST = ABS( E( M ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ $ SAFMIN )GO TO 60 50 CONTINUE END IF * M = LEND * 60 CONTINUE IF( M.LT.LEND ) $ E( M ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 80 * * If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L+1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) WORK( L ) = C WORK( N-1+L ) = S CALL SLASR( 'R', 'V', 'B', N, 2, WORK( L ), $ WORK( N-1+L ), Z( 1, L ), LDZ ) ELSE CALL SLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) END IF D( L ) = RT1 D( L+1 ) = RT2 E( L ) = ZERO L = L + 2 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L+1 )-P ) / ( TWO*E( L ) ) R = SLAPY2( G, ONE ) G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * MM1 = M - 1 DO 70 I = MM1, L, -1 F = S*E( I ) B = C*E( I ) CALL SLARTG( G, F, C, S, R ) IF( I.NE.M-1 ) $ E( I+1 ) = R G = D( I+1 ) - P R = ( D( I )-G )*S + TWO*C*B P = S*R D( I+1 ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = -S END IF * 70 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = M - L + 1 CALL SLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), $ Z( 1, L ), LDZ ) END IF * D( L ) = D( L ) - P E( L ) = G GO TO 40 * * Eigenvalue found. * 80 CONTINUE D( L ) = P * L = L + 1 IF( L.LE.LEND ) $ GO TO 40 GO TO 140 * ELSE * * QR Iteration * * Look for small superdiagonal element. * 90 CONTINUE IF( L.NE.LEND ) THEN LENDP1 = LEND + 1 DO 100 M = L, LENDP1, -1 TST = ABS( E( M-1 ) )**2 IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ $ SAFMIN )GO TO 110 100 CONTINUE END IF * M = LEND * 110 CONTINUE IF( M.GT.LEND ) $ E( M-1 ) = ZERO P = D( L ) IF( M.EQ.L ) $ GO TO 130 * * If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 * to compute its eigensystem. * IF( M.EQ.L-1 ) THEN IF( ICOMPZ.GT.0 ) THEN CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) WORK( M ) = C WORK( N-1+M ) = S CALL SLASR( 'R', 'V', 'F', N, 2, WORK( M ), $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) ELSE CALL SLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) END IF D( L-1 ) = RT1 D( L ) = RT2 E( L-1 ) = ZERO L = L - 2 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 END IF * IF( JTOT.EQ.NMAXIT ) $ GO TO 140 JTOT = JTOT + 1 * * Form shift. * G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) R = SLAPY2( G, ONE ) G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) * S = ONE C = ONE P = ZERO * * Inner loop * LM1 = L - 1 DO 120 I = M, LM1 F = S*E( I ) B = C*E( I ) CALL SLARTG( G, F, C, S, R ) IF( I.NE.M ) $ E( I-1 ) = R G = D( I ) - P R = ( D( I+1 )-G )*S + TWO*C*B P = S*R D( I ) = G + P G = C*R - B * * If eigenvectors are desired, then save rotations. * IF( ICOMPZ.GT.0 ) THEN WORK( I ) = C WORK( N-1+I ) = S END IF * 120 CONTINUE * * If eigenvectors are desired, then apply saved rotations. * IF( ICOMPZ.GT.0 ) THEN MM = L - M + 1 CALL SLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), $ Z( 1, M ), LDZ ) END IF * D( L ) = D( L ) - P E( LM1 ) = G GO TO 90 * * Eigenvalue found. * 130 CONTINUE D( L ) = P * L = L - 1 IF( L.GE.LEND ) $ GO TO 90 GO TO 140 * END IF * * Undo scaling if necessary * 140 CONTINUE IF( ISCALE.EQ.1 ) THEN CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) ELSE IF( ISCALE.EQ.2 ) THEN CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, $ D( LSV ), N, INFO ) CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), $ N, INFO ) END IF * * Check for no convergence to an eigenvalue after a total * of N*MAXIT iterations. * IF( JTOT.LT.NMAXIT ) $ GO TO 10 DO 150 I = 1, N - 1 IF( E( I ).NE.ZERO ) $ INFO = INFO + 1 150 CONTINUE GO TO 190 * * Order eigenvalues and eigenvectors. * 160 CONTINUE IF( ICOMPZ.EQ.0 ) THEN * * Use Quick Sort * CALL SLASRT( 'I', N, D, INFO ) * ELSE * * Use Selection Sort to minimize swaps of eigenvectors * DO 180 II = 2, N I = II - 1 K = I P = D( I ) DO 170 J = II, N IF( D( J ).LT.P ) THEN K = J P = D( J ) END IF 170 CONTINUE IF( K.NE.I ) THEN D( K ) = D( I ) D( I ) = P CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) END IF 180 CONTINUE END IF * 190 CONTINUE RETURN * * End of SSTEQR * END arpack-akloeckner-07/LAPACK/strevc.f0000644000175000017500000010421606153460175017116 0ustar andreasandreas SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * Purpose * ======= * * STREVC computes some or all of the right and/or left eigenvectors of * a real upper quasi-triangular matrix T. * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: * * T*x = w*x, y'*T = w*y' * * where y' denotes the conjugate transpose of the vector y. * * If all eigenvectors are requested, the routine may either return the * matrices X and/or Y of right or left eigenvectors of T, or the * products Q*X and/or Q*Y, where Q is an input orthogonal * matrix. If T was obtained from the real-Schur factorization of an * original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of * right or left eigenvectors of A. * * T must be in Schur canonical form (as returned by SHSEQR), that is, * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each * 2-by-2 diagonal block has its diagonal elements equal and its * off-diagonal elements of opposite sign. Corresponding to each 2-by-2 * diagonal block is a complex conjugate pair of eigenvalues and * eigenvectors; only one eigenvector of the pair is computed, namely * the one corresponding to the eigenvalue with positive imaginary part. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'R': compute right eigenvectors only; * = 'L': compute left eigenvectors only; * = 'B': compute both right and left eigenvectors. * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, * and backtransform them using the input matrices * supplied in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input/output) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. * If HOWMNY = 'A' or 'B', SELECT is not referenced. * To select the real eigenvector corresponding to a real * eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select * the complex eigenvector corresponding to a complex conjugate * pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be * set to .TRUE.; then on exit SELECT(j) is .TRUE. and * SELECT(j+1) is .FALSE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input) REAL array, dimension (LDT,N) * The upper quasi-triangular matrix T in Schur canonical form. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * VL (input/output) REAL array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of Schur vectors returned by SHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part, and the second the imaginary part. * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= max(1,N) if * SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) REAL array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must * contain an N-by-N matrix Q (usually the orthogonal matrix Q * of Schur vectors returned by SHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. * A complex eigenvector corresponding to a complex eigenvalue * is stored in two consecutive columns, the first holding the * real part and the second the imaginary part. * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= max(1,N) if * SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) INTEGER * The number of columns in the arrays VL and/or VR actually * used to store the eigenvectors. * If HOWMNY = 'A' or 'B', M is set to N. * Each selected real eigenvector occupies one column and each * selected complex eigenvector occupies two columns. * * WORK (workspace) REAL array, dimension (3*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The algorithm used in this program is basically backward (forward) * substitution, with scaling to make the the code robust against * possible overflow. * * Each eigenvector is normalized so that the element of largest * magnitude has magnitude 1; here the magnitude of a complex number * (x,y) is taken to be |x| + |y|. * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2 REAL BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE, $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR, $ XNORM * .. * .. External Functions .. LOGICAL LSAME INTEGER ISAMAX REAL SDOT, SLAMCH EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH * .. * .. External Subroutines .. EXTERNAL SAXPY, SCOPY, SGEMV, SLABAD, SLALN2, SSCAL, $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Local Arrays .. REAL X( 2, 2 ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'O' ) SOMEV = LSAME( HOWMNY, 'S' ) * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE * * Set M to the number of columns required to store the selected * eigenvectors, standardize the array SELECT if necessary, and * test MM. * IF( SOMEV ) THEN M = 0 PAIR = .FALSE. DO 10 J = 1, N IF( PAIR ) THEN PAIR = .FALSE. SELECT( J ) = .FALSE. ELSE IF( J.LT.N ) THEN IF( T( J+1, J ).EQ.ZERO ) THEN IF( SELECT( J ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN SELECT( J ) = .TRUE. M = M + 2 END IF END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE ELSE M = N END IF * IF( MM.LT.M ) THEN INFO = -11 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set the constants to control overflow. * UNFL = SLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL SLABAD( UNFL, OVFL ) ULP = SLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) BIGNUM = ( ONE-ULP ) / SMLNUM * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * WORK( 1 ) = ZERO DO 30 J = 2, N WORK( J ) = ZERO DO 20 I = 1, J - 1 WORK( J ) = WORK( J ) + ABS( T( I, J ) ) 20 CONTINUE 30 CONTINUE * * Index IP is used to specify the real or complex eigenvalue: * IP = 0, real eigenvalue, * 1, first of conjugate complex pair: (wr,wi) * -1, second of conjugate complex pair: (wr,wi) * N2 = 2*N * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IP = 0 IS = M DO 140 KI = N, 1, -1 * IF( IP.EQ.1 ) $ GO TO 130 IF( KI.EQ.1 ) $ GO TO 40 IF( T( KI, KI-1 ).EQ.ZERO ) $ GO TO 40 IP = -1 * 40 CONTINUE IF( SOMEV ) THEN IF( IP.EQ.0 ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 ELSE IF( .NOT.SELECT( KI-1 ) ) $ GO TO 130 END IF END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI-1 ) ) )* $ SQRT( ABS( T( KI-1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real right eigenvector * WORK( KI+N ) = ONE * * Form right-hand side * DO 50 K = 1, KI - 1 WORK( K+N ) = -T( K, KI ) 50 CONTINUE * * Solve the upper quasi-triangular system: * (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. * JNXT = KI - 1 DO 60 J = KI - 1, 1, -1 IF( J.GT.JNXT ) $ GO TO 60 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J+N ) = X( 1, 1 ) * * Update right-hand side * CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, ZERO, X, 2, $ SCALE, XNORM, IERR ) * * Scale X(1,1) and X(2,1) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 2, 1 ) = X( 2, 1 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 ) WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) * * Update right-hand side * CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) END IF 60 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 ) * II = ISAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / ABS( VR( II, IS ) ) CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 70 K = KI + 1, N VR( K, IS ) = ZERO 70 CONTINUE ELSE IF( KI.GT.1 ) $ CALL SGEMV( 'N', N, KI-1, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI+N ), $ VR( 1, KI ), 1 ) * II = ISAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / ABS( VR( II, KI ) ) CALL SSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF * ELSE * * Complex right eigenvector. * * Initial solve * [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. * [ (T(KI,KI-1) T(KI,KI) ) ] * IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN WORK( KI-1+N ) = ONE WORK( KI+N2 ) = WI / T( KI-1, KI ) ELSE WORK( KI-1+N ) = -WI / T( KI, KI-1 ) WORK( KI+N2 ) = ONE END IF WORK( KI+N ) = ZERO WORK( KI-1+N2 ) = ZERO * * Form right-hand side * DO 80 K = 1, KI - 2 WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 ) WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI ) 80 CONTINUE * * Solve upper quasi-triangular system: * (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) * JNXT = KI - 2 DO 90 J = KI - 2, 1, -1 IF( J.GT.JNXT ) $ GO TO 90 J1 = J J2 = J JNXT = J - 1 IF( J.GT.1 ) THEN IF( T( J, J-1 ).NE.ZERO ) THEN J1 = J - 1 JNXT = J - 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI, $ X, 2, SCALE, XNORM, IERR ) * * Scale X(1,1) and X(1,2) to avoid overflow when * updating the right-hand side. * IF( XNORM.GT.ONE ) THEN IF( WORK( J ).GT.BIGNUM / XNORM ) THEN X( 1, 1 ) = X( 1, 1 ) / XNORM X( 1, 2 ) = X( 1, 2 ) / XNORM SCALE = SCALE / XNORM END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) * * Update the right-hand side * CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL SAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) * ELSE * * 2-by-2 diagonal block * CALL SLALN2( .FALSE., 2, 2, SMIN, ONE, $ T( J-1, J-1 ), LDT, ONE, ONE, $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE, $ XNORM, IERR ) * * Scale X to avoid overflow when updating * the right-hand side. * IF( XNORM.GT.ONE ) THEN BETA = MAX( WORK( J-1 ), WORK( J ) ) IF( BETA.GT.BIGNUM / XNORM ) THEN REC = ONE / XNORM X( 1, 1 ) = X( 1, 1 )*REC X( 1, 2 ) = X( 1, 2 )*REC X( 2, 1 ) = X( 2, 1 )*REC X( 2, 2 ) = X( 2, 2 )*REC SCALE = SCALE*REC END IF END IF * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 ) CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 ) END IF WORK( J-1+N ) = X( 1, 1 ) WORK( J+N ) = X( 2, 1 ) WORK( J-1+N2 ) = X( 1, 2 ) WORK( J+N2 ) = X( 2, 2 ) * * Update the right-hand side * CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1, $ WORK( 1+N ), 1 ) CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1, $ WORK( 1+N ), 1 ) CALL SAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1, $ WORK( 1+N2 ), 1 ) CALL SAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1, $ WORK( 1+N2 ), 1 ) END IF 90 CONTINUE * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 ) CALL SCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 ) * EMAX = ZERO DO 100 K = 1, KI EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+ $ ABS( VR( K, IS ) ) ) 100 CONTINUE * REMAX = ONE / EMAX CALL SSCAL( KI, REMAX, VR( 1, IS-1 ), 1 ) CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 110 K = KI + 1, N VR( K, IS-1 ) = ZERO VR( K, IS ) = ZERO 110 CONTINUE * ELSE * IF( KI.GT.2 ) THEN CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N ), 1, WORK( KI-1+N ), $ VR( 1, KI-1 ), 1 ) CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR, $ WORK( 1+N2 ), 1, WORK( KI+N2 ), $ VR( 1, KI ), 1 ) ELSE CALL SSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 ) CALL SSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 ) END IF * EMAX = ZERO DO 120 K = 1, N EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+ $ ABS( VR( K, KI ) ) ) 120 CONTINUE REMAX = ONE / EMAX CALL SSCAL( N, REMAX, VR( 1, KI-1 ), 1 ) CALL SSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF END IF * IS = IS - 1 IF( IP.NE.0 ) $ IS = IS - 1 130 CONTINUE IF( IP.EQ.1 ) $ IP = 0 IF( IP.EQ.-1 ) $ IP = 1 140 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IP = 0 IS = 1 DO 260 KI = 1, N * IF( IP.EQ.-1 ) $ GO TO 250 IF( KI.EQ.N ) $ GO TO 150 IF( T( KI+1, KI ).EQ.ZERO ) $ GO TO 150 IP = 1 * 150 CONTINUE IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 250 END IF * * Compute the KI-th eigenvalue (WR,WI). * WR = T( KI, KI ) WI = ZERO IF( IP.NE.0 ) $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* $ SQRT( ABS( T( KI+1, KI ) ) ) SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) * IF( IP.EQ.0 ) THEN * * Real left eigenvector. * WORK( KI+N ) = ONE * * Form right-hand side * DO 160 K = KI + 1, N WORK( K+N ) = -T( KI, K ) 160 CONTINUE * * Solve the quasi-triangular system: * (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 1 DO 170 J = KI + 1, N IF( J.LT.JNXT ) $ GO TO 170 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ SDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * * Solve (T(J,J)-WR)'*X = WORK * CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) VMAX = MAX( ABS( WORK( J+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ SDOT( J-KI-1, T( KI+1, J ), 1, $ WORK( KI+1+N ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ SDOT( J-KI-1, T( KI+1, J+1 ), 1, $ WORK( KI+1+N ), 1 ) * * Solve * [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) * [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ ZERO, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) $ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) WORK( J+N ) = X( 1, 1 ) WORK( J+1+N ) = X( 2, 1 ) * VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+1+N ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 170 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) * II = ISAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / ABS( VL( II, IS ) ) CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 180 K = 1, KI - 1 VL( K, IS ) = ZERO 180 CONTINUE * ELSE * IF( KI.LT.N ) $ CALL SGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) * II = ISAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / ABS( VL( II, KI ) ) CALL SSCAL( N, REMAX, VL( 1, KI ), 1 ) * END IF * ELSE * * Complex left eigenvector. * * Initial solve: * ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. * ((T(KI+1,KI) T(KI+1,KI+1)) ) * IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN WORK( KI+N ) = WI / T( KI, KI+1 ) WORK( KI+1+N2 ) = ONE ELSE WORK( KI+N ) = ONE WORK( KI+1+N2 ) = -WI / T( KI+1, KI ) END IF WORK( KI+1+N ) = ZERO WORK( KI+N2 ) = ZERO * * Form right-hand side * DO 190 K = KI + 2, N WORK( K+N ) = -WORK( KI+N )*T( KI, K ) WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K ) 190 CONTINUE * * Solve complex quasi-triangular system: * ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 * VMAX = ONE VCRIT = BIGNUM * JNXT = KI + 2 DO 200 J = KI + 2, N IF( J.LT.JNXT ) $ GO TO 200 J1 = J J2 = J JNXT = J + 1 IF( J.LT.N ) THEN IF( T( J+1, J ).NE.ZERO ) THEN J2 = J + 1 JNXT = J + 2 END IF END IF * IF( J1.EQ.J2 ) THEN * * 1-by-1 diagonal block * * Scale if necessary to avoid overflow when * forming the right-hand side elements. * IF( WORK( J ).GT.VCRIT ) THEN REC = ONE / VMAX CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ SDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) WORK( J+N2 ) = WORK( J+N2 ) - $ SDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 * CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) VMAX = MAX( ABS( WORK( J+N ) ), $ ABS( WORK( J+N2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * ELSE * * 2-by-2 diagonal block * * Scale if necessary to avoid overflow when forming * the right-hand side elements. * BETA = MAX( WORK( J ), WORK( J+1 ) ) IF( BETA.GT.VCRIT ) THEN REC = ONE / VMAX CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 ) CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 ) VMAX = ONE VCRIT = BIGNUM END IF * WORK( J+N ) = WORK( J+N ) - $ SDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+N2 ) = WORK( J+N2 ) - $ SDOT( J-KI-2, T( KI+2, J ), 1, $ WORK( KI+2+N2 ), 1 ) * WORK( J+1+N ) = WORK( J+1+N ) - $ SDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N ), 1 ) * WORK( J+1+N2 ) = WORK( J+1+N2 ) - $ SDOT( J-KI-2, T( KI+2, J+1 ), 1, $ WORK( KI+2+N2 ), 1 ) * * Solve 2-by-2 complex linear equation * ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B * ([T(j+1,j) T(j+1,j+1)] ) * CALL SLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ), $ LDT, ONE, ONE, WORK( J+N ), N, WR, $ -WI, X, 2, SCALE, XNORM, IERR ) * * Scale if necessary * IF( SCALE.NE.ONE ) THEN CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 ) CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 ) END IF WORK( J+N ) = X( 1, 1 ) WORK( J+N2 ) = X( 1, 2 ) WORK( J+1+N ) = X( 2, 1 ) WORK( J+1+N2 ) = X( 2, 2 ) VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX ) VCRIT = BIGNUM / VMAX * END IF 200 CONTINUE * * Copy the vector x or Q*x to VL and normalize. * 210 CONTINUE IF( .NOT.OVER ) THEN CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 ) CALL SCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ), $ 1 ) * EMAX = ZERO DO 220 K = KI, N EMAX = MAX( EMAX, ABS( VL( K, IS ) )+ $ ABS( VL( K, IS+1 ) ) ) 220 CONTINUE REMAX = ONE / EMAX CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) CALL SSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 ) * DO 230 K = 1, KI - 1 VL( K, IS ) = ZERO VL( K, IS+1 ) = ZERO 230 CONTINUE ELSE IF( KI.LT.N-1 ) THEN CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ), $ VL( 1, KI ), 1 ) CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ), $ LDVL, WORK( KI+2+N2 ), 1, $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) ELSE CALL SSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 ) CALL SSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 ) END IF * EMAX = ZERO DO 240 K = 1, N EMAX = MAX( EMAX, ABS( VL( K, KI ) )+ $ ABS( VL( K, KI+1 ) ) ) 240 CONTINUE REMAX = ONE / EMAX CALL SSCAL( N, REMAX, VL( 1, KI ), 1 ) CALL SSCAL( N, REMAX, VL( 1, KI+1 ), 1 ) * END IF * END IF * IS = IS + 1 IF( IP.NE.0 ) $ IS = IS + 1 250 CONTINUE IF( IP.EQ.-1 ) $ IP = 0 IF( IP.EQ.1 ) $ IP = -1 * 260 CONTINUE * END IF * RETURN * * End of STREVC * END arpack-akloeckner-07/LAPACK/strexc.f0000644000175000017500000002414006153460175017115 0ustar andreasandreas SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) * .. * * Purpose * ======= * * STREXC reorders the real Schur factorization of a real matrix * A = Q*T*Q**T, so that the diagonal block of T with row index IFST is * moved to row ILST. * * The real Schur form T is reordered by an orthogonal similarity * transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors * is updated by postmultiplying it with Z. * * T must be in Schur canonical form (as returned by SHSEQR), that is, * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each * 2-by-2 diagonal block has its diagonal elements equal and its * off-diagonal elements of opposite sign. * * Arguments * ========= * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) REAL array, dimension (LDT,N) * On entry, the upper quasi-triangular matrix T, in Schur * Schur canonical form. * On exit, the reordered upper quasi-triangular matrix, again * in Schur canonical form. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) REAL array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * orthogonal transformation matrix Z which reorders T. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= max(1,N). * * IFST (input/output) INTEGER * ILST (input/output) INTEGER * Specify the reordering of the diagonal blocks of T. * The block with row index IFST is moved to row ILST, by a * sequence of transpositions between adjacent blocks. * On exit, if IFST pointed on entry to the second row of a * 2-by-2 block, it is changed to point to the first row; ILST * always points to the first row of the block in its final * position (which may differ from its input value by +1 or -1). * 1 <= IFST <= N; 1 <= ILST <= N. * * WORK (workspace) REAL array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1: two adjacent blocks were too close to swap (the problem * is very ill-conditioned); T may have been partially * reordered, and ILST points to the first row of the * current position of the block being moved. * * ===================================================================== * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. * .. Local Scalars .. LOGICAL WANTQ INTEGER HERE, NBF, NBL, NBNEXT * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL SLAEXC, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Decode and test the input arguments. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -7 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.LE.1 ) $ RETURN * * Determine the first row of specified block * and find out it is 1 by 1 or 2 by 2. * IF( IFST.GT.1 ) THEN IF( T( IFST, IFST-1 ).NE.ZERO ) $ IFST = IFST - 1 END IF NBF = 1 IF( IFST.LT.N ) THEN IF( T( IFST+1, IFST ).NE.ZERO ) $ NBF = 2 END IF * * Determine the first row of the final block * and find out it is 1 by 1 or 2 by 2. * IF( ILST.GT.1 ) THEN IF( T( ILST, ILST-1 ).NE.ZERO ) $ ILST = ILST - 1 END IF NBL = 1 IF( ILST.LT.N ) THEN IF( T( ILST+1, ILST ).NE.ZERO ) $ NBL = 2 END IF * IF( IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Update ILST * IF( NBF.EQ.2 .AND. NBL.EQ.1 ) $ ILST = ILST - 1 IF( NBF.EQ.1 .AND. NBL.EQ.2 ) $ ILST = ILST + 1 * HERE = IFST * 10 CONTINUE * * Swap block with next one below * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE+NBF+1.LE.N ) THEN IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO ) $ NBNEXT = 2 END IF CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE+3.LE.N ) THEN IF( T( HERE+3, HERE+2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT, $ WORK, INFO ) HERE = HERE + 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE+2, HERE+1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, $ NBNEXT, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE + 2 ELSE * * 2 by 2 Block did split * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1, $ WORK, INFO ) HERE = HERE + 2 END IF END IF END IF IF( HERE.LT.ILST ) $ GO TO 10 * ELSE * HERE = IFST 20 CONTINUE * * Swap block with next one above * IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN * * Current block either 1 by 1 or 2 by 2 * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ NBF, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - NBNEXT * * Test if 2 by 2 block breaks into two 1 by 1 blocks * IF( NBF.EQ.2 ) THEN IF( T( HERE+1, HERE ).EQ.ZERO ) $ NBF = 3 END IF * ELSE * * Current block consists of two 1 by 1 blocks each of which * must be swapped individually * NBNEXT = 1 IF( HERE.GE.3 ) THEN IF( T( HERE-1, HERE-2 ).NE.ZERO ) $ NBNEXT = 2 END IF CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT, $ 1, WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF IF( NBNEXT.EQ.1 ) THEN * * Swap two 1 by 1 blocks, no problems possible * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1, $ WORK, INFO ) HERE = HERE - 1 ELSE * * Recompute NBNEXT in case 2 by 2 split * IF( T( HERE, HERE-1 ).EQ.ZERO ) $ NBNEXT = 1 IF( NBNEXT.EQ.2 ) THEN * * 2 by 2 Block did not split * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1, $ WORK, INFO ) IF( INFO.NE.0 ) THEN ILST = HERE RETURN END IF HERE = HERE - 2 ELSE * * 2 by 2 Block did split * CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1, $ WORK, INFO ) CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1, $ WORK, INFO ) HERE = HERE - 2 END IF END IF END IF IF( HERE.GT.ILST ) $ GO TO 20 END IF ILST = HERE * RETURN * * End of STREXC * END arpack-akloeckner-07/LAPACK/strsen.f0000644000175000017500000003400406153460175017123 0ustar andreasandreas SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N REAL S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) INTEGER IWORK( * ) REAL Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), $ WR( * ) * .. * * Purpose * ======= * * STRSEN reorders the real Schur factorization of a real matrix * A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in * the leading diagonal blocks of the upper quasi-triangular matrix T, * and the leading columns of Q form an orthonormal basis of the * corresponding right invariant subspace. * * Optionally the routine computes the reciprocal condition numbers of * the cluster of eigenvalues and/or the invariant subspace. * * T must be in Schur canonical form (as returned by SHSEQR), that is, * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each * 2-by-2 diagonal block has its diagonal elemnts equal and its * off-diagonal elements of opposite sign. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies whether condition numbers are required for the * cluster of eigenvalues (S) or the invariant subspace (SEP): * = 'N': none; * = 'E': for eigenvalues only (S); * = 'V': for invariant subspace only (SEP); * = 'B': for both eigenvalues and invariant subspace (S and * SEP). * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * SELECT (input) LOGICAL array, dimension (N) * SELECT specifies the eigenvalues in the selected cluster. To * select a real eigenvalue w(j), SELECT(j) must be set to * .TRUE.. To select a complex conjugate pair of eigenvalues * w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, * either SELECT(j) or SELECT(j+1) or both must be set to * .TRUE.; a complex conjugate pair of eigenvalues must be * either both included in the cluster or both excluded. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) REAL array, dimension (LDT,N) * On entry, the upper quasi-triangular matrix T, in Schur * canonical form. * On exit, T is overwritten by the reordered matrix T, again in * Schur canonical form, with the selected eigenvalues in the * leading diagonal blocks. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) REAL array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * orthogonal transformation matrix which reorders T; the * leading M columns of Q form an orthonormal basis for the * specified invariant subspace. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= 1; and if COMPQ = 'V', LDQ >= N. * * WR (output) REAL array, dimension (N) * WI (output) REAL array, dimension (N) * The real and imaginary parts, respectively, of the reordered * eigenvalues of T. The eigenvalues are stored in the same * order as on the diagonal of T, with WR(i) = T(i,i) and, if * T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and * WI(i+1) = -WI(i). Note that if a complex eigenvalue is * sufficiently ill-conditioned, then its value may differ * significantly from its value before reordering. * * M (output) INTEGER * The dimension of the specified invariant subspace. * 0 < = M <= N. * * S (output) REAL * If JOB = 'E' or 'B', S is a lower bound on the reciprocal * condition number for the selected cluster of eigenvalues. * S cannot underestimate the true reciprocal condition number * by more than a factor of sqrt(N). If M = 0 or N, S = 1. * If JOB = 'N' or 'V', S is not referenced. * * SEP (output) REAL * If JOB = 'V' or 'B', SEP is the estimated reciprocal * condition number of the specified invariant subspace. If * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * * WORK (workspace) REAL array, dimension (LWORK) * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= max(1,N); * if JOB = 'E', LWORK >= M*(N-M); * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). * * IWORK (workspace) INTEGER array, dimension (LIWORK) * IF JOB = 'N' or 'E', IWORK is not referenced. * * LIWORK (input) INTEGER * The dimension of the array IWORK. * If JOB = 'N' or 'E', LIWORK >= 1; * if JOB = 'V' or 'B', LIWORK >= M*(N-M). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1: reordering of T failed because some eigenvalues are too * close to separate (the problem is very ill-conditioned); * T may have been partially reordered, and WR and WI * contain the eigenvalues in the same order as in T; S and * SEP (if requested) are set to zero. * * Further Details * =============== * * STRSEN first collects the selected eigenvalues by computing an * orthogonal transformation Z to move them to the top left corner of T. * In other words, the selected eigenvalues are the eigenvalues of T11 * in: * * Z'*T*Z = ( T11 T12 ) n1 * ( 0 T22 ) n2 * n1 n2 * * where N = n1+n2 and Z' means the transpose of Z. The first n1 columns * of Z span the specified invariant subspace of T. * * If T has been obtained from the real Schur factorization of a matrix * A = Q*T*Q', then the reordered real Schur factorization of A is given * by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span * the corresponding invariant subspace of A. * * The reciprocal condition number of the average of the eigenvalues of * T11 may be returned in S. S lies between 0 (very badly conditioned) * and 1 (very well conditioned). It is computed as follows. First we * compute R so that * * P = ( I R ) n1 * ( 0 0 ) n2 * n1 n2 * * is the projector on the invariant subspace associated with T11. * R is the solution of the Sylvester equation: * * T11*R - R*T22 = T12. * * Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote * the two-norm of M. Then S is computed as the lower bound * * (1 + F-norm(R)**2)**(-1/2) * * on the reciprocal of 2-norm(P), the true reciprocal condition number. * S cannot underestimate 1 / 2-norm(P) by more than a factor of * sqrt(N). * * An approximate error bound for the computed average of the * eigenvalues of T11 is * * EPS * norm(T) / S * * where EPS is the machine precision. * * The reciprocal condition number of the right invariant subspace * spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. * SEP is defined as the separation of T11 and T22: * * sep( T11, T22 ) = sigma-min( C ) * * where sigma-min(C) is the smallest singular value of the * n1*n2-by-n1*n2 matrix * * C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) * * I(m) is an m by m identity matrix, and kprod denotes the Kronecker * product. We estimate sigma-min(C) by the reciprocal of an estimate of * the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) * cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). * * When SEP is small, small changes in T can cause large changes in * the invariant subspace. An approximate bound on the maximum angular * error in the computed right invariant subspace is * * EPS * norm(T) / SEP * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL PAIR, SWAP, WANTBH, WANTQ, WANTS, WANTSP INTEGER IERR, K, KASE, KK, KS, N1, N2, NN REAL EST, RNORM, SCALE * .. * .. External Functions .. LOGICAL LSAME REAL SLANGE EXTERNAL LSAME, SLANGE * .. * .. External Subroutines .. EXTERNAL SLACON, SLACPY, STREXC, STRSYL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE * * Set M to the dimension of the specified invariant subspace, * and test LWORK and LIWORK. * M = 0 PAIR = .FALSE. DO 10 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE IF( K.LT.N ) THEN IF( T( K+1, K ).EQ.ZERO ) THEN IF( SELECT( K ) ) $ M = M + 1 ELSE PAIR = .TRUE. IF( SELECT( K ) .OR. SELECT( K+1 ) ) $ M = M + 2 END IF ELSE IF( SELECT( N ) ) $ M = M + 1 END IF END IF 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * IF( LWORK.LT.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND. $ LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN INFO = -15 ELSE IF( LIWORK.LT.1 .OR. ( WANTSP .AND. LIWORK.LT.NN ) ) THEN INFO = -17 END IF END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STRSEN', -INFO ) RETURN END IF * * Quick return if possible. * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = SLANGE( '1', N, N, T, LDT, WORK ) GO TO 40 END IF * * Collect the selected blocks at the top-left corner of T. * KS = 0 PAIR = .FALSE. DO 20 K = 1, N IF( PAIR ) THEN PAIR = .FALSE. ELSE SWAP = SELECT( K ) IF( K.LT.N ) THEN IF( T( K+1, K ).NE.ZERO ) THEN PAIR = .TRUE. SWAP = SWAP .OR. SELECT( K+1 ) END IF END IF IF( SWAP ) THEN KS = KS + 1 * * Swap the K-th block to position KS. * IERR = 0 KK = K IF( K.NE.KS ) $ CALL STREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK, $ IERR ) IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN * * Blocks too close to swap: exit. * INFO = 1 IF( WANTS ) $ S = ZERO IF( WANTSP ) $ SEP = ZERO GO TO 40 END IF IF( PAIR ) $ KS = KS + 1 END IF END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL SLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL STRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = SLANGE( 'F', N1, N2, WORK, N1, WORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL SLACON( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL STRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11'*R - R*T22' = scale*X. * CALL STRSYL( 'T', 'T', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Store the output eigenvalues in WR and WI. * DO 50 K = 1, N WR( K ) = T( K, K ) WI( K ) = ZERO 50 CONTINUE DO 60 K = 1, N - 1 IF( T( K+1, K ).NE.ZERO ) THEN WI( K ) = SQRT( ABS( T( K, K+1 ) ) )* $ SQRT( ABS( T( K+1, K ) ) ) WI( K+1 ) = -WI( K ) END IF 60 CONTINUE RETURN * * End of STRSEN * END arpack-akloeckner-07/LAPACK/strsyl.f0000644000175000017500000010164106153460175017147 0ustar andreasandreas SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N REAL SCALE * .. * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * STRSYL solves the real Sylvester matrix equation: * * op(A)*X + X*op(B) = scale*C or * op(A)*X - X*op(B) = scale*C, * * where op(A) = A or A**T, and A and B are both upper quasi- * triangular. A is M-by-M and B is N-by-N; the right hand side C and * the solution X are M-by-N; and scale is an output scale factor, set * <= 1 to avoid overflow in X. * * A and B must be in Schur canonical form (as returned by SHSEQR), that * is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; * each 2-by-2 diagonal block has its diagonal elements equal and its * off-diagonal elements of opposite sign. * * Arguments * ========= * * TRANA (input) CHARACTER*1 * Specifies the option op(A): * = 'N': op(A) = A (No transpose) * = 'T': op(A) = A**T (Transpose) * = 'C': op(A) = A**H (Conjugate transpose = Transpose) * * TRANB (input) CHARACTER*1 * Specifies the option op(B): * = 'N': op(B) = B (No transpose) * = 'T': op(B) = B**T (Transpose) * = 'C': op(B) = B**H (Conjugate transpose = Transpose) * * ISGN (input) INTEGER * Specifies the sign in the equation: * = +1: solve op(A)*X + X*op(B) = scale*C * = -1: solve op(A)*X - X*op(B) = scale*C * * M (input) INTEGER * The order of the matrix A, and the number of rows in the * matrices X and C. M >= 0. * * N (input) INTEGER * The order of the matrix B, and the number of columns in the * matrices X and C. N >= 0. * * A (input) REAL array, dimension (LDA,M) * The upper quasi-triangular matrix A, in Schur canonical form. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (input) REAL array, dimension (LDB,N) * The upper quasi-triangular matrix B, in Schur canonical form. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * C (input/output) REAL array, dimension (LDC,N) * On entry, the M-by-N right hand side matrix C. * On exit, C is overwritten by the solution matrix X. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M) * * SCALE (output) REAL * The scale factor, scale, set <= 1 to avoid overflow in X. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1: A and B have common or very close eigenvalues; perturbed * values were used to solve the equation (but the matrices * A and B are unchanged). * * ===================================================================== * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT REAL A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM, SUML, SUMR, XNORM * .. * .. Local Arrays .. REAL DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) * .. * .. External Functions .. LOGICAL LSAME REAL SDOT, SLAMCH, SLANGE EXTERNAL LSAME, SDOT, SLAMCH, SLANGE * .. * .. External Subroutines .. EXTERNAL SLABAD, SLALN2, SLASY2, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. $ LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. $ LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'STRSYL', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = SLAMCH( 'P' ) SMLNUM = SLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL SLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*REAL( M*N ) / EPS BIGNUM = ONE / SMLNUM * SMIN = MAX( SMLNUM, EPS*SLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*SLANGE( 'M', N, N, B, LDB, DUM ) ) * SCALE = ONE SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * * Start column loop (index = L) * L1 (L2) : column index of the first (first) row of X(K,L). * LNEXT = 1 DO 70 L = 1, N IF( L.LT.LNEXT ) $ GO TO 70 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L). * KNEXT = M DO 60 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 60 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 20 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 20 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL SLASY2( .FALSE., .FALSE., ISGN, 2, 2, $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, $ 2, SCALOC, X, 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 50 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 50 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 60 CONTINUE * 70 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A' *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 L-1 * R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = 1 DO 130 L = 1, N IF( L.LT.LNEXT ) $ GO TO 130 IF( L.EQ.N ) THEN L1 = L L2 = L ELSE IF( B( L+1, L ).NE.ZERO ) THEN L1 = L L2 = L + 1 LNEXT = L + 2 ELSE L1 = L L2 = L LNEXT = L + 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 120 K = 1, M IF( K.LT.KNEXT ) $ GO TO 120 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 80 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 80 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 90 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 90 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL SLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 110 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 110 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 120 CONTINUE 130 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A'*X + ISGN*X*B' = scale*C. * * The (K,L)th block of X is determined starting from * top-right corner column by column by * * A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) * * Where * K-1 N * R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. * I=1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 190 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 190 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = 1 DO 180 K = 1, M IF( K.LT.KNEXT ) $ GO TO 180 IF( K.EQ.M ) THEN K1 = K K2 = K ELSE IF( A( K+1, K ).NE.ZERO ) THEN K1 = K K2 = K + 1 KNEXT = K + 2 ELSE K1 = K K2 = K KNEXT = K + 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 140 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 140 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 150 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 150 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 160 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 160 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN(L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL SLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 170 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 170 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 180 CONTINUE 190 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B' = scale*C. * * The (K,L)th block of X is determined starting from * bottom-right corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. * I=K+1 J=L+1 * * Start column loop (index = L) * L1 (L2): column index of the first (last) row of X(K,L) * LNEXT = N DO 250 L = N, 1, -1 IF( L.GT.LNEXT ) $ GO TO 250 IF( L.EQ.1 ) THEN L1 = L L2 = L ELSE IF( B( L, L-1 ).NE.ZERO ) THEN L1 = L - 1 L2 = L LNEXT = L - 2 ELSE L1 = L L2 = L LNEXT = L - 1 END IF END IF * * Start row loop (index = K) * K1 (K2): row index of the first (last) row of X(K,L) * KNEXT = M DO 240 K = M, 1, -1 IF( K.GT.KNEXT ) $ GO TO 240 IF( K.EQ.1 ) THEN K1 = K K2 = K ELSE IF( A( K, K-1 ).NE.ZERO ) THEN K1 = K - 1 K2 = K KNEXT = K - 2 ELSE K1 = K K2 = K KNEXT = K - 1 END IF END IF * IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN SUML = SDOT( M-K1, A( K1, MIN(K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC, $ B( L1, MIN( L1+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) SCALOC = ONE * A11 = A( K1, K1 ) + SGN*B( L1, L1 ) DA11 = ABS( A11 ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( VEC( 1, 1 ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 200 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 200 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) * ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ), $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 210 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 210 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K2, L1 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN * SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) ) * SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA, $ C( MIN( K1+1, M ), L2 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) ) * CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ), $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ), $ ZERO, X, 2, SCALOC, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 220 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 220 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 2, 1 ) * ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L1 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L1, MIN( L2+1, N ) ), LDB ) VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR ) * SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA, $ C( MIN( K2+1, M ), L2 ), 1 ) SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC, $ B( L2, MIN( L2+1, N ) ), LDB ) VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR ) * CALL SLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, $ 2, XNORM, IERR ) IF( IERR.NE.0 ) $ INFO = 1 * IF( SCALOC.NE.ONE ) THEN DO 230 J = 1, N CALL SSCAL( M, SCALOC, C( 1, J ), 1 ) 230 CONTINUE SCALE = SCALE*SCALOC END IF C( K1, L1 ) = X( 1, 1 ) C( K1, L2 ) = X( 1, 2 ) C( K2, L1 ) = X( 2, 1 ) C( K2, L2 ) = X( 2, 2 ) END IF * 240 CONTINUE 250 CONTINUE * END IF * RETURN * * End of STRSYL * END arpack-akloeckner-07/LAPACK/xerbla.f0000644000175000017500000000233406153460175017063 0ustar andreasandreas SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * ===================================================================== * * .. Executable Statements .. * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END arpack-akloeckner-07/LAPACK/xlaenv.f0000644000175000017500000000451606153460176017110 0ustar andreasandreas SUBROUTINE XLAENV( ISPEC, NVALUE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. INTEGER ISPEC, NVALUE * .. * * Purpose * ======= * * XLAENV sets certain machine- and problem-dependent quantities * which will later be retrieved by ILAENV. * * Arguments * ========= * * ISPEC (input) INTEGER * Specifies the parameter to be set in the COMMON array IPARMS. * = 1: the optimal blocksize; if this value is 1, an unblocked * algorithm will give the best performance. * = 2: the minimum block size for which the block routine * should be used; if the usable block size is less than * this value, an unblocked routine should be used. * = 3: the crossover point (in a block routine, for N less * than this value, an unblocked routine should be used) * = 4: the number of shifts, used in the nonsymmetric * eigenvalue routines * = 5: the minimum column dimension for blocking to be used; * rectangular blocks must have dimension at least k by m, * where k is given by ILAENV(2,...) and m by ILAENV(5,...) * = 6: the crossover point for the SVD (when reducing an m by n * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds * this value, a QR factorization is used first to reduce * the matrix to a triangular form) * = 7: the number of processors * = 8: another crossover point, for the multishift QR and QZ * methods for nonsymmetric eigenvalue problems. * * NVALUE (input) INTEGER * The value of the parameter specified by ISPEC. * * ===================================================================== * * .. Arrays in Common .. INTEGER IPARMS( 100 ) * .. * .. Common blocks .. COMMON / CLAENV / IPARMS * .. * .. Save statement .. SAVE / CLAENV / * .. * .. Executable Statements .. * IF( ISPEC.GE.1 .AND. ISPEC.LE.8 ) THEN IPARMS( ISPEC ) = NVALUE END IF * RETURN * * End of XLAENV * END arpack-akloeckner-07/LAPACK/zdscal.f0000644000175000017500000000125306153460176017066 0ustar andreasandreas subroutine zdscal(n,da,zx,incx) c c scales a vector by a constant. c jack dongarra, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*) double precision da integer i,incx,ix,n c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 do 10 i = 1,n zx(ix) = dcmplx(da,0.0d0)*zx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 do 30 i = 1,n zx(i) = dcmplx(da,0.0d0)*zx(i) 30 continue return end arpack-akloeckner-07/LAPACK/zgbtf2.f0000644000175000017500000001420706153460176017007 0ustar andreasandreas SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 2.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, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 AB( LDAB, * ) * .. * * Purpose * ======= * * ZGBTF2 computes an LU factorization of a complex m-by-n band matrix * A using partial pivoting with row interchanges. * * This is the unblocked version of the algorithm, calling Level 2 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) COMPLEX*16 array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U, because of fill-in resulting from the row * interchanges. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, J, JP, JU, KM, KV * .. * .. External Functions .. INTEGER IZAMAX EXTERNAL IZAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGERU, ZSCAL, ZSWAP * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in. * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGBTF2', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero. * DO 20 J = KU + 2, MIN( KV, N ) DO 10 I = KV - J + 2, KL AB( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * JU is the index of the last column affected by the current stage * of the factorization. * JU = 1 * DO 40 J = 1, MIN( M, N ) * * Set fill-in elements in column J+KV to zero. * IF( J+KV.LE.N ) THEN DO 30 I = 1, KL AB( I, J+KV ) = ZERO 30 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-J ) JP = IZAMAX( KM+1, AB( KV+1, J ), 1 ) IPIV( J ) = JP + J - 1 IF( AB( KV+JP, J ).NE.ZERO ) THEN JU = MAX( JU, MIN( J+KU+JP-1, N ) ) * * Apply interchange to columns J to JU. * IF( JP.NE.1 ) $ CALL ZSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, $ AB( KV+1, J ), LDAB-1 ) IF( KM.GT.0 ) THEN * * Compute multipliers. * CALL ZSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) * * Update trailing submatrix within the band. * IF( JU.GT.J ) $ CALL ZGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1, $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), $ LDAB-1 ) END IF ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = J END IF 40 CONTINUE RETURN * * End of ZGBTF2 * END arpack-akloeckner-07/LAPACK/zgbtrf.f0000644000175000017500000003437106153460176017113 0ustar andreasandreas SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * * -- LAPACK routine (version 2.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, KL, KU, LDAB, M, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 AB( LDAB, * ) * .. * * Purpose * ======= * * ZGBTRF computes an LU factorization of a complex m-by-n band matrix A * using partial pivoting with row interchanges. * * This is the blocked version of the algorithm, calling Level 3 BLAS. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * AB (input/output) COMPLEX*16 array, dimension (LDAB,N) * On entry, the matrix A in band storage, in rows KL+1 to * 2*KL+KU+1; rows 1 to KL of the array need not be set. * The j-th column of A is stored in the j-th column of the * array AB as follows: * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) * * On exit, details of the factorization: U is stored as an * upper triangular band matrix with KL+KU superdiagonals in * rows 1 to KL+KU+1, and the multipliers used during the * factorization are stored in rows KL+KU+2 to 2*KL+KU+1. * See below for further details. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * 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. * * Further Details * =============== * * The band storage scheme is illustrated by the following example, when * M = N = 6, KL = 2, KU = 1: * * On entry: On exit: * * * * * + + + * * * u14 u25 u36 * * * + + + + * * u13 u24 u35 u46 * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * * a31 a42 a53 a64 * * m31 m42 m53 m64 * * * * Array elements marked * are not used by the routine; elements marked * + need not be set on entry, but are required by the routine to store * elements of U because of fill-in resulting from the row interchanges. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) INTEGER NBMAX, LDWORK PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) * .. * .. Local Scalars .. INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, $ JU, K2, KM, KV, NB, NW COMPLEX*16 TEMP * .. * .. Local Arrays .. COMPLEX*16 WORK13( LDWORK, NBMAX ), $ WORK31( LDWORK, NBMAX ) * .. * .. External Functions .. INTEGER ILAENV, IZAMAX EXTERNAL ILAENV, IZAMAX * .. * .. External Subroutines .. EXTERNAL XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU, ZLASWP, $ ZSCAL, ZSWAP, ZTRSM * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Executable Statements .. * * KV is the number of superdiagonals in the factor U, allowing for * fill-in * KV = KU + KL * * Test the input parameters. * INFO = 0 IF( M.LT.0 ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( LDAB.LT.KL+KV+1 ) THEN INFO = -6 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGBTRF', -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 = ILAENV( 1, 'ZGBTRF', ' ', M, N, KL, KU ) * * The block size must not exceed the limit set by the size of the * local arrays WORK13 and WORK31. * NB = MIN( NB, NBMAX ) * IF( NB.LE.1 .OR. NB.GT.KL ) THEN * * Use unblocked code * CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) ELSE * * Use blocked code * * Zero the superdiagonal elements of the work array WORK13 * DO 20 J = 1, NB DO 10 I = 1, J - 1 WORK13( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * * Zero the subdiagonal elements of the work array WORK31 * DO 40 J = 1, NB DO 30 I = J + 1, NB WORK31( I, J ) = ZERO 30 CONTINUE 40 CONTINUE * * Gaussian elimination with partial pivoting * * Set fill-in elements in columns KU+2 to KV to zero * DO 60 J = KU + 2, MIN( KV, N ) DO 50 I = KV - J + 2, KL AB( I, J ) = ZERO 50 CONTINUE 60 CONTINUE * * JU is the index of the last column affected by the current * stage of the factorization * JU = 1 * DO 180 J = 1, MIN( M, N ), NB JB = MIN( NB, MIN( M, N )-J+1 ) * * The active part of the matrix is partitioned * * A11 A12 A13 * A21 A22 A23 * A31 A32 A33 * * Here A11, A21 and A31 denote the current block of JB columns * which is about to be factorized. The number of rows in the * partitioning are JB, I2, I3 respectively, and the numbers * of columns are JB, J2, J3. The superdiagonal elements of A13 * and the subdiagonal elements of A31 lie outside the band. * I2 = MIN( KL-JB, M-J-JB+1 ) I3 = MIN( JB, M-J-KL+1 ) * * J2 and J3 are computed after JU has been updated. * * Factorize the current block of JB columns * DO 80 JJ = J, J + JB - 1 * * Set fill-in elements in column JJ+KV to zero * IF( JJ+KV.LE.N ) THEN DO 70 I = 1, KL AB( I, JJ+KV ) = ZERO 70 CONTINUE END IF * * Find pivot and test for singularity. KM is the number of * subdiagonal elements in the current column. * KM = MIN( KL, M-JJ ) JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 ) IPIV( JJ ) = JP + JJ - J IF( AB( KV+JP, JJ ).NE.ZERO ) THEN JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) IF( JP.NE.1 ) THEN * * Apply interchange to columns J to J+JB-1 * IF( JP+JJ-1.LT.J+KL ) THEN * CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange affects columns J to JJ-1 of A31 * which are stored in the work array WORK31 * CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, $ AB( KV+JP, JJ ), LDAB-1 ) END IF END IF * * Compute multipliers * CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), $ 1 ) * * Update trailing submatrix within the band and within * the current block. JM is the index of the last column * which needs to be updated. * JM = MIN( JU, J+JB-1 ) IF( JM.GT.JJ ) $ CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, $ AB( KV, JJ+1 ), LDAB-1, $ AB( KV+1, JJ+1 ), LDAB-1 ) ELSE * * If pivot is zero, set INFO to the index of the pivot * unless a zero pivot has already been found. * IF( INFO.EQ.0 ) $ INFO = JJ END IF * * Copy current column of A31 into the work array WORK31 * NW = MIN( JJ-J+1, I3 ) IF( NW.GT.0 ) $ CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, $ WORK31( 1, JJ-J+1 ), 1 ) 80 CONTINUE IF( J+JB.LE.N ) THEN * * Apply the row interchanges to the other blocks. * J2 = MIN( JU-J+1, KV ) - JB J3 = MAX( 0, JU-J-KV+1 ) * * Use ZLASWP to apply the row interchanges to A12, A22, and * A32. * CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, $ IPIV( J ), 1 ) * * Adjust the pivot indices. * DO 90 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 90 CONTINUE * * Apply the row interchanges to A13, A23, and A33 * columnwise. * K2 = J - 1 + JB + J2 DO 110 I = 1, J3 JJ = K2 + I DO 100 II = J + I - 1, J + JB - 1 IP = IPIV( II ) IF( IP.NE.II ) THEN TEMP = AB( KV+1+II-JJ, JJ ) AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) AB( KV+1+IP-JJ, JJ ) = TEMP END IF 100 CONTINUE 110 CONTINUE * * Update the relevant part of the trailing submatrix * IF( J2.GT.0 ) THEN * * Update A12 * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1 ) * IF( I2.GT.0 ) THEN * * Update A22 * CALL ZGEMM( 'No transpose', 'No transpose', I2, J2, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+1, J+JB ), LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A32 * CALL ZGEMM( 'No transpose', 'No transpose', I3, J2, $ JB, -ONE, WORK31, LDWORK, $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) END IF END IF * IF( J3.GT.0 ) THEN * * Copy the lower triangle of A13 into the work array * WORK13 * DO 130 JJ = 1, J3 DO 120 II = JJ, JB WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) 120 CONTINUE 130 CONTINUE * * Update A13 in the work array * CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, $ WORK13, LDWORK ) * IF( I2.GT.0 ) THEN * * Update A23 * CALL ZGEMM( 'No transpose', 'No transpose', I2, J3, $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), $ LDAB-1 ) END IF * IF( I3.GT.0 ) THEN * * Update A33 * CALL ZGEMM( 'No transpose', 'No transpose', I3, J3, $ JB, -ONE, WORK31, LDWORK, WORK13, $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) END IF * * Copy the lower triangle of A13 back into place * DO 150 JJ = 1, J3 DO 140 II = JJ, JB AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) 140 CONTINUE 150 CONTINUE END IF ELSE * * Adjust the pivot indices. * DO 160 I = J, J + JB - 1 IPIV( I ) = IPIV( I ) + J - 1 160 CONTINUE END IF * * Partially undo the interchanges in the current block to * restore the upper triangular form of A31 and copy the upper * triangle of A31 back into place * DO 170 JJ = J + JB - 1, J, -1 JP = IPIV( JJ ) - JJ + 1 IF( JP.NE.1 ) THEN * * Apply interchange to columns J to JJ-1 * IF( JP+JJ-1.LT.J+KL ) THEN * * The interchange does not affect A31 * CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) ELSE * * The interchange does affect A31 * CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) END IF END IF * * Copy the current column of A31 back into place * NW = MIN( I3, JJ-J+1 ) IF( NW.GT.0 ) $ CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1, $ AB( KV+KL+1-JJ+J, JJ ), 1 ) 170 CONTINUE 180 CONTINUE END IF * RETURN * * End of ZGBTRF * END arpack-akloeckner-07/LAPACK/zgbtrs.f0000644000175000017500000001453706153460176017132 0ustar andreasandreas SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 2.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, KL, KU, LDAB, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 AB( LDAB, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZGBTRS solves a system of linear equations * A * X = B, A**T * X = B, or A**H * X = B * with a general band matrix A using the LU factorization computed * by ZGBTRF. * * 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. * * KL (input) INTEGER * The number of subdiagonals within the band of A. KL >= 0. * * KU (input) INTEGER * The number of superdiagonals within the band of A. KU >= 0. * * NRHS (input) INTEGER * The number of right hand sides, i.e., the number of columns * of the matrix B. NRHS >= 0. * * AB (input) COMPLEX*16 array, dimension (LDAB,N) * Details of the LU factorization of the band matrix A, as * computed by ZGBTRF. U is stored as an upper triangular band * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and * the multipliers used during the factorization are stored in * rows KL+KU+2 to 2*KL+KU+1. * * LDAB (input) INTEGER * The leading dimension of the array AB. LDAB >= 2*KL+KU+1. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= N, row i of the matrix was * interchanged with row IPIV(i). * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, the solution matrix X. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LNOTI, NOTRAN INTEGER I, J, KD, L, LM * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZGEMV, ZGERU, ZLACGV, ZSWAP, ZTBSV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. 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( KL.LT.0 ) THEN INFO = -3 ELSE IF( KU.LT.0 ) THEN INFO = -4 ELSE IF( NRHS.LT.0 ) THEN INFO = -5 ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGBTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * KD = KU + KL + 1 LNOTI = KL.GT.0 * IF( NOTRAN ) THEN * * Solve A*X = B. * * Solve L*X = B, overwriting B with X. * * L is represented as a product of permutations and unit lower * triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), * where each transformation L(i) is a rank-one modification of * the identity matrix. * IF( LNOTI ) THEN DO 10 J = 1, N - 1 LM = MIN( KL, N-J ) L = IPIV( J ) IF( L.NE.J ) $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) CALL ZGERU( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), $ LDB, B( J+1, 1 ), LDB ) 10 CONTINUE END IF * DO 20 I = 1, NRHS * * Solve U*X = B, overwriting B with X. * CALL ZTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, $ AB, LDAB, B( 1, I ), 1 ) 20 CONTINUE * ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * X = B. * DO 30 I = 1, NRHS * * Solve U**T * X = B, overwriting B with X. * CALL ZTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, $ LDAB, B( 1, I ), 1 ) 30 CONTINUE * * Solve L**T * X = B, overwriting B with X. * IF( LNOTI ) THEN DO 40 J = N - 1, 1, -1 LM = MIN( KL, N-J ) CALL ZGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) L = IPIV( J ) IF( L.NE.J ) $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 40 CONTINUE END IF * ELSE * * Solve A**H * X = B. * DO 50 I = 1, NRHS * * Solve U**H * X = B, overwriting B with X. * CALL ZTBSV( 'Upper', 'Conjugate transpose', 'Non-unit', N, $ KL+KU, AB, LDAB, B( 1, I ), 1 ) 50 CONTINUE * * Solve L**H * X = B, overwriting B with X. * IF( LNOTI ) THEN DO 60 J = N - 1, 1, -1 LM = MIN( KL, N-J ) CALL ZLACGV( NRHS, B( J, 1 ), LDB ) CALL ZGEMV( 'Conjugate transpose', LM, NRHS, -ONE, $ B( J+1, 1 ), LDB, AB( KD+1, J ), 1, ONE, $ B( J, 1 ), LDB ) CALL ZLACGV( NRHS, B( J, 1 ), LDB ) L = IPIV( J ) IF( L.NE.J ) $ CALL ZSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) 60 CONTINUE END IF END IF RETURN * * End of ZGBTRS * END arpack-akloeckner-07/LAPACK/zgeqr2.f0000644000175000017500000000653406153460176017027 0ustar andreasandreas SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * -- LAPACK routine (version 2.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 .. COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZGEQR2 computes a QR factorization of a complex m by n matrix A: * A = Q * R. * * Arguments * ========= * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, the elements on and above the diagonal of the array * contain the min(m,n) by n upper trapezoidal matrix R (R is * upper triangular if m >= n); the elements below the diagonal, * with the array TAU, represent the unitary matrix Q as a * product of elementary reflectors (see Further Details). * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * TAU (output) COMPLEX*16 array, dimension (min(M,N)) * The scalar factors of the elementary reflectors (see Further * Details). * * WORK (workspace) COMPLEX*16 array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The matrix Q is represented as a product of elementary reflectors * * Q = H(1) H(2) . . . H(k), where k = min(m,n). * * Each H(i) has the form * * H(i) = I - tau * v * v' * * where tau is a complex scalar, and v is a complex vector with * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), * and tau in TAU(i). * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. INTEGER I, K COMPLEX*16 ALPHA * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF, ZLARFG * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, MIN * .. * .. Executable Statements .. * * Test the input arguments * 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( 'ZGEQR2', -INFO ) RETURN END IF * K = MIN( M, N ) * DO 10 I = 1, K * * Generate elementary reflector H(i) to annihilate A(i+1:m,i) * CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAU( I ) ) IF( I.LT.N ) THEN * * Apply H(i)' to A(i:m,i+1:n) from the left * ALPHA = A( I, I ) A( I, I ) = ONE CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) A( I, I ) = ALPHA END IF 10 CONTINUE RETURN * * End of ZGEQR2 * END arpack-akloeckner-07/LAPACK/zgttrf.f0000644000175000017500000001116606153460176017132 0ustar andreasandreas SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * * -- LAPACK routine (version 2.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, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * ZGTTRF computes an LU factorization of a complex tridiagonal matrix A * using elimination with partial pivoting and row interchanges. * * The factorization has the form * A = L * U * where L is a product of permutation and unit lower bidiagonal * matrices and U is upper triangular with nonzeros in only the main * diagonal and first two superdiagonals. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix A. N >= 0. * * DL (input/output) COMPLEX*16 array, dimension (N-1) * On entry, DL must contain the (n-1) subdiagonal elements of * A. * On exit, DL is overwritten by the (n-1) multipliers that * define the matrix L from the LU factorization of A. * * D (input/output) COMPLEX*16 array, dimension (N) * On entry, D must contain the diagonal elements of A. * On exit, D is overwritten by the n diagonal elements of the * upper triangular matrix U from the LU factorization of A. * * DU (input/output) COMPLEX*16 array, dimension (N-1) * On entry, DU must contain the (n-1) superdiagonal elements * of A. * On exit, DU is overwritten by the (n-1) elements of the first * superdiagonal of U. * * DU2 (output) COMPLEX*16 array, dimension (N-2) * On exit, DU2 is overwritten by the (n-2) elements of the * second superdiagonal of U. * * IPIV (output) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * 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. * * ===================================================================== * * .. Local Scalars .. INTEGER I COMPLEX*16 FACT, TEMP, ZDUM * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Parameters .. COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) * .. * .. Executable Statements .. * INFO = 0 IF( N.LT.0 ) THEN INFO = -1 CALL XERBLA( 'ZGTTRF', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Initialize IPIV(i) = i * DO 10 I = 1, N IPIV( I ) = I 10 CONTINUE * DO 20 I = 1, N - 1 IF( DL( I ).EQ.CZERO ) THEN * * Subdiagonal is zero, no elimination is required. * IF( D( I ).EQ.CZERO .AND. INFO.EQ.0 ) $ INFO = I IF( I.LT.N-1 ) $ DU2( I ) = CZERO ELSE IF( CABS1( D( I ) ).GE.CABS1( DL( I ) ) ) THEN * * No row interchange required, eliminate DL(I) * FACT = DL( I ) / D( I ) DL( I ) = FACT D( I+1 ) = D( I+1 ) - FACT*DU( I ) IF( I.LT.N-1 ) $ DU2( I ) = CZERO ELSE * * Interchange rows I and I+1, eliminate DL(I) * FACT = D( I ) / DL( I ) D( I ) = DL( I ) DL( I ) = FACT TEMP = DU( I ) DU( I ) = D( I+1 ) D( I+1 ) = TEMP - FACT*D( I+1 ) IF( I.LT.N-1 ) THEN DU2( I ) = DU( I+1 ) DU( I+1 ) = -FACT*DU( I+1 ) END IF IPIV( I ) = IPIV( I ) + 1 END IF 20 CONTINUE IF( D( N ).EQ.CZERO .AND. INFO.EQ.0 ) THEN INFO = N RETURN END IF * RETURN * * End of ZGTTRF * END arpack-akloeckner-07/LAPACK/zgttrs.f0000644000175000017500000001417506153460176017152 0ustar andreasandreas SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * * -- LAPACK routine (version 2.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, LDB, N, NRHS * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * ) * .. * * Purpose * ======= * * ZGTTRS solves one of the systems of equations * A * X = B, A**T * X = B, or A**H * X = B, * with a tridiagonal matrix A using the LU factorization computed * by ZGTTRF. * * Arguments * ========= * * TRANS (input) CHARACTER * 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. * * DL (input) COMPLEX*16 array, dimension (N-1) * The (n-1) multipliers that define the matrix L from the * LU factorization of A. * * D (input) COMPLEX*16 array, dimension (N) * The n diagonal elements of the upper triangular matrix U from * the LU factorization of A. * * DU (input) COMPLEX*16 array, dimension (N-1) * The (n-1) elements of the first superdiagonal of U. * * DU2 (input) COMPLEX*16 array, dimension (N-2) * The (n-2) elements of the second superdiagonal of U. * * IPIV (input) INTEGER array, dimension (N) * The pivot indices; for 1 <= i <= n, row i of the matrix was * interchanged with row IPIV(i). IPIV(i) will always be either * i or i+1; IPIV(i) = i indicates a row interchange was not * required. * * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) * On entry, the right hand side matrix B. * On exit, B is overwritten by 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 * * ===================================================================== * * .. Local Scalars .. LOGICAL NOTRAN INTEGER I, J COMPLEX*16 TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * 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( LDB.LT.MAX( N, 1 ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZGTTRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. NRHS.EQ.0 ) $ RETURN * IF( NOTRAN ) THEN * * Solve A*X = B using the LU factorization of A, * overwriting each right hand side vector with its solution. * DO 30 J = 1, NRHS * * Solve L*x = b. * DO 10 I = 1, N - 1 IF( IPIV( I ).EQ.I ) THEN B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J ) ELSE TEMP = B( I, J ) B( I, J ) = B( I+1, J ) B( I+1, J ) = TEMP - DL( I )*B( I, J ) END IF 10 CONTINUE * * Solve U*x = b. * B( N, J ) = B( N, J ) / D( N ) IF( N.GT.1 ) $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / $ D( N-1 ) DO 20 I = N - 2, 1, -1 B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )* $ B( I+2, J ) ) / D( I ) 20 CONTINUE 30 CONTINUE ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * X = B. * DO 60 J = 1, NRHS * * Solve U**T * x = b. * B( 1, J ) = B( 1, J ) / D( 1 ) IF( N.GT.1 ) $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 ) DO 40 I = 3, N B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )* $ B( I-2, J ) ) / D( I ) 40 CONTINUE * * Solve L**T * x = b. * DO 50 I = N - 1, 1, -1 IF( IPIV( I ).EQ.I ) THEN B( I, J ) = B( I, J ) - DL( I )*B( I+1, J ) ELSE TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - DL( I )*TEMP B( I, J ) = TEMP END IF 50 CONTINUE 60 CONTINUE ELSE * * Solve A**H * X = B. * DO 90 J = 1, NRHS * * Solve U**H * x = b. * B( 1, J ) = B( 1, J ) / DCONJG( D( 1 ) ) IF( N.GT.1 ) $ B( 2, J ) = ( B( 2, J )-DCONJG( DU( 1 ) )*B( 1, J ) ) / $ DCONJG( D( 2 ) ) DO 70 I = 3, N B( I, J ) = ( B( I, J )-DCONJG( DU( I-1 ) )*B( I-1, J )- $ DCONJG( DU2( I-2 ) )*B( I-2, J ) ) / $ DCONJG( D( I ) ) 70 CONTINUE * * Solve L**H * x = b. * DO 80 I = N - 1, 1, -1 IF( IPIV( I ).EQ.I ) THEN B( I, J ) = B( I, J ) - DCONJG( DL( I ) )*B( I+1, J ) ELSE TEMP = B( I+1, J ) B( I+1, J ) = B( I, J ) - DCONJG( DL( I ) )*TEMP B( I, J ) = TEMP END IF 80 CONTINUE 90 CONTINUE END IF * * End of ZGTTRS * END arpack-akloeckner-07/LAPACK/zlacgv.f0000644000175000017500000000273106153460176017076 0ustar andreasandreas SUBROUTINE ZLACGV( N, X, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLACGV conjugates a complex vector of length N. * * Arguments * ========= * * N (input) INTEGER * The length of the vector X. N >= 0. * * X (input/output) COMPLEX*16 array, dimension * (1+(N-1)*abs(INCX)) * On entry, the vector of length N to be conjugated. * On exit, X is overwritten with conjg(X). * * INCX (input) INTEGER * The spacing between successive elements of X. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IOFF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( INCX.EQ.1 ) THEN DO 10 I = 1, N X( I ) = DCONJG( X( I ) ) 10 CONTINUE ELSE IOFF = 1 IF( INCX.LT.0 ) $ IOFF = 1 - ( N-1 )*INCX DO 20 I = 1, N X( IOFF ) = DCONJG( X( IOFF ) ) IOFF = IOFF + INCX 20 CONTINUE END IF RETURN * * End of ZLACGV * END arpack-akloeckner-07/LAPACK/zlacon.f0000644000175000017500000001237006153460176017076 0ustar andreasandreas SUBROUTINE ZLACON( N, V, X, EST, KASE ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER KASE, N DOUBLE PRECISION EST * .. * .. Array Arguments .. COMPLEX*16 V( N ), X( N ) * .. * * Purpose * ======= * * ZLACON estimates the 1-norm of a square, complex matrix A. * Reverse communication is used for evaluating matrix-vector products. * * Arguments * ========= * * N (input) INTEGER * The order of the matrix. N >= 1. * * V (workspace) COMPLEX*16 array, dimension (N) * On the final return, V = A*W, where EST = norm(V)/norm(W) * (W is not returned). * * X (input/output) COMPLEX*16 array, dimension (N) * On an intermediate return, X should be overwritten by * A * X, if KASE=1, * A' * X, if KASE=2, * where A' is the conjugate transpose of A, and ZLACON must be * re-called with all the other parameters unchanged. * * EST (output) DOUBLE PRECISION * An estimate (a lower bound) for norm(A). * * KASE (input/output) INTEGER * On the initial call to ZLACON, KASE should be 0. * On an intermediate return, KASE will be 1 or 2, indicating * whether X should be overwritten by A * X or A' * X. * On the final return from ZLACON, KASE will again be 0. * * Further Details * ======= ======= * * Contributed by Nick Higham, University of Manchester. * Originally named CONEST, dated March 16, 1988. * * Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of * a real or complex matrix, with applications to condition estimation", * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. * * ===================================================================== * * .. Parameters .. INTEGER ITMAX PARAMETER ( ITMAX = 5 ) DOUBLE PRECISION ONE, TWO PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) COMPLEX*16 CZERO, CONE PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ), $ CONE = ( 1.0D0, 0.0D0 ) ) * .. * .. Local Scalars .. INTEGER I, ITER, J, JLAST, JUMP DOUBLE PRECISION ALTSGN, ESTOLD, SAFMIN, TEMP * .. * .. External Functions .. INTEGER IZMAX1 DOUBLE PRECISION DLAMCH, DZSUM1 EXTERNAL IZMAX1, DLAMCH, DZSUM1 * .. * .. External Subroutines .. EXTERNAL ZCOPY * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX * .. * .. Save statement .. SAVE * .. * .. Executable Statements .. * SAFMIN = DLAMCH( 'Safe minimum' ) IF( KASE.EQ.0 ) THEN DO 10 I = 1, N X( I ) = DCMPLX( ONE / DBLE( N ) ) 10 CONTINUE KASE = 1 JUMP = 1 RETURN END IF * GO TO ( 20, 40, 70, 90, 120 )JUMP * * ................ ENTRY (JUMP = 1) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. * 20 CONTINUE IF( N.EQ.1 ) THEN V( 1 ) = X( 1 ) EST = ABS( V( 1 ) ) * ... QUIT GO TO 130 END IF EST = DZSUM1( N, X, 1 ) * DO 30 I = 1, N IF( ABS( X( I ) ).GT.SAFMIN ) THEN X( I ) = X( I ) / DCMPLX( ABS( X( I ) ) ) ELSE X( I ) = CONE END IF 30 CONTINUE KASE = 2 JUMP = 2 RETURN * * ................ ENTRY (JUMP = 2) * FIRST ITERATION. X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. * 40 CONTINUE J = IZMAX1( N, X, 1 ) ITER = 2 * * MAIN LOOP - ITERATIONS 2,3,...,ITMAX. * 50 CONTINUE DO 60 I = 1, N X( I ) = CZERO 60 CONTINUE X( J ) = CONE KASE = 1 JUMP = 3 RETURN * * ................ ENTRY (JUMP = 3) * X HAS BEEN OVERWRITTEN BY A*X. * 70 CONTINUE CALL ZCOPY( N, X, 1, V, 1 ) ESTOLD = EST EST = DZSUM1( N, V, 1 ) * * TEST FOR CYCLING. IF( EST.LE.ESTOLD ) $ GO TO 100 * DO 80 I = 1, N IF( ABS( X( I ) ).GT.SAFMIN ) THEN X( I ) = X( I ) / DCMPLX( ABS( X( I ) ) ) ELSE X( I ) = CONE END IF 80 CONTINUE KASE = 2 JUMP = 4 RETURN * * ................ ENTRY (JUMP = 4) * X HAS BEEN OVERWRITTEN BY ZTRANS(A)*X. * 90 CONTINUE JLAST = J J = IZMAX1( N, X, 1 ) IF( ( DBLE( X( JLAST ) ).NE.ABS( DBLE( X( J ) ) ) ) .AND. $ ( ITER.LT.ITMAX ) ) THEN ITER = ITER + 1 GO TO 50 END IF * * ITERATION COMPLETE. FINAL STAGE. * 100 CONTINUE ALTSGN = ONE DO 110 I = 1, N X( I ) = DCMPLX( ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) ) ALTSGN = -ALTSGN 110 CONTINUE KASE = 1 JUMP = 5 RETURN * * ................ ENTRY (JUMP = 5) * X HAS BEEN OVERWRITTEN BY A*X. * 120 CONTINUE TEMP = TWO*( DZSUM1( N, X, 1 ) / DBLE( 3*N ) ) IF( TEMP.GT.EST ) THEN CALL ZCOPY( N, X, 1, V, 1 ) EST = TEMP END IF * 130 CONTINUE KASE = 0 RETURN * * End of ZLACON * END arpack-akloeckner-07/LAPACK/zlacpy.f0000644000175000017500000000457006153460176017115 0ustar andreasandreas SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * * -- LAPACK auxiliary routine (version 2.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 LDA, LDB, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ) * .. * * Purpose * ======= * * ZLACPY copies all or part of a two-dimensional matrix A to another * matrix B. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be copied to B. * = 'U': Upper triangular part * = 'L': Lower triangular part * Otherwise: All of the matrix A * * 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) COMPLEX*16 array, dimension (LDA,N) * The m by n matrix A. If UPLO = 'U', only the upper trapezium * is accessed; if UPLO = 'L', only the lower trapezium is * accessed. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (output) COMPLEX*16 array, dimension (LDB,N) * On exit, B = A in the locations specified by UPLO. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN DO 20 J = 1, N DO 10 I = 1, MIN( J, M ) B( I, J ) = A( I, J ) 10 CONTINUE 20 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN DO 40 J = 1, N DO 30 I = J, M B( I, J ) = A( I, J ) 30 CONTINUE 40 CONTINUE * ELSE DO 60 J = 1, N DO 50 I = 1, M B( I, J ) = A( I, J ) 50 CONTINUE 60 CONTINUE END IF * RETURN * * End of ZLACPY * END arpack-akloeckner-07/LAPACK/zladiv.f0000644000175000017500000000217006153460177017077 0ustar andreasandreas DOUBLE COMPLEX FUNCTION ZLADIV( X, Y ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. COMPLEX*16 X, Y * .. * * Purpose * ======= * * ZLADIV := X / Y, where X and Y are complex. The computation of X / Y * will not overflow on an intermediary step unless the results * overflows. * * Arguments * ========= * * X (input) COMPLEX*16 * Y (input) COMPLEX*16 * The complex scalars X and Y. * * ===================================================================== * * .. Local Scalars .. DOUBLE PRECISION ZI, ZR * .. * .. External Subroutines .. EXTERNAL DLADIV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, DIMAG * .. * .. Executable Statements .. * CALL DLADIV( DBLE( X ), DIMAG( X ), DBLE( Y ), DIMAG( Y ), ZR, $ ZI ) ZLADIV = DCMPLX( ZR, ZI ) * RETURN * * End of ZLADIV * END arpack-akloeckner-07/LAPACK/zlahqr.f0000644000175000017500000003007506153460177017114 0ustar andreasandreas SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. LOGICAL WANTT, WANTZ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N * .. * .. Array Arguments .. COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) * .. * * Purpose * ======= * * ZLAHQR is an auxiliary routine called by CHSEQR to update the * eigenvalues and Schur decomposition already computed by CHSEQR, by * dealing with the Hessenberg submatrix in rows and columns ILO to IHI. * * Arguments * ========= * * WANTT (input) LOGICAL * = .TRUE. : the full Schur form T is required; * = .FALSE.: only eigenvalues are required. * * WANTZ (input) LOGICAL * = .TRUE. : the matrix of Schur vectors Z is required; * = .FALSE.: Schur vectors are not required. * * N (input) INTEGER * The order of the matrix H. N >= 0. * * ILO (input) INTEGER * IHI (input) INTEGER * It is assumed that H is already upper triangular in rows and * columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). * ZLAHQR works primarily with the Hessenberg submatrix in rows * and columns ILO to IHI, but applies transformations to all of * H if WANTT is .TRUE.. * 1 <= ILO <= max(1,IHI); IHI <= N. * * H (input/output) COMPLEX*16 array, dimension (LDH,N) * On entry, the upper Hessenberg matrix H. * On exit, if WANTT is .TRUE., H is upper triangular in rows * and columns ILO:IHI, with any 2-by-2 diagonal blocks in * standard form. If WANTT is .FALSE., the contents of H are * unspecified on exit. * * LDH (input) INTEGER * The leading dimension of the array H. LDH >= max(1,N). * * W (output) COMPLEX*16 array, dimension (N) * The computed eigenvalues ILO to IHI are stored in the * corresponding elements of W. If WANTT is .TRUE., the * eigenvalues are stored in the same order as on the diagonal * of the Schur form returned in H, with W(i) = H(i,i). * * ILOZ (input) INTEGER * IHIZ (input) INTEGER * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. * * Z (input/output) COMPLEX*16 array, dimension (LDZ,N) * If WANTZ is .TRUE., on entry Z must contain the current * matrix Z of transformations accumulated by CHSEQR, and on * exit Z has been updated; transformations are applied only to * the submatrix Z(ILOZ:IHIZ,ILO:IHI). * If WANTZ is .FALSE., Z is not referenced. * * LDZ (input) INTEGER * The leading dimension of the array Z. LDZ >= max(1,N). * * INFO (output) INTEGER * = 0: successful exit * > 0: if INFO = i, ZLAHQR failed to compute all the * eigenvalues ILO to IHI in a total of 30*(IHI-ILO+1) * iterations; elements i+1:ihi of W contain those * eigenvalues which have been successfully computed. * * ===================================================================== * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) DOUBLE PRECISION RZERO, HALF PARAMETER ( RZERO = 0.0D+0, HALF = 0.5D+0 ) * .. * .. Local Scalars .. INTEGER I, I1, I2, ITN, ITS, J, K, L, M, NH, NZ DOUBLE PRECISION H10, H21, RTEMP, S, SMLNUM, T2, TST1, ULP COMPLEX*16 CDUM, H11, H11S, H22, SUM, T, T1, TEMP, U, V2, $ X, Y * .. * .. Local Arrays .. DOUBLE PRECISION RWORK( 1 ) COMPLEX*16 V( 2 ) * .. * .. External Functions .. DOUBLE PRECISION ZLANHS, DLAMCH COMPLEX*16 ZLADIV EXTERNAL ZLANHS, DLAMCH, ZLADIV * .. * .. External Subroutines .. EXTERNAL ZCOPY, ZLARFG, ZSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DIMAG, DCONJG, MAX, MIN, DBLE, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * INFO = 0 * * Quick return if possible * IF( N.EQ.0 ) $ RETURN IF( ILO.EQ.IHI ) THEN W( ILO ) = H( ILO, ILO ) RETURN END IF * NH = IHI - ILO + 1 NZ = IHIZ - ILOZ + 1 * * Set machine-dependent constants for the stopping criterion. * If norm(H) <= sqrt(OVFL), overflow should not occur. * ULP = DLAMCH( 'Precision' ) SMLNUM = DLAMCH( 'Safe minimum' ) / ULP * * I1 and I2 are the indices of the first row and last column of H * to which transformations must be applied. If eigenvalues only are * being computed, I1 and I2 are set inside the main loop. * IF( WANTT ) THEN I1 = 1 I2 = N END IF * * ITN is the total number of QR iterations allowed. * ITN = 30*NH * * The main loop begins here. I is the loop index and decreases from * IHI to ILO in steps of 1. Each iteration of the loop works * with the active submatrix in rows and columns L to I. * Eigenvalues I+1 to IHI have already converged. Either L = ILO, or * H(L,L-1) is negligible so that the matrix splits. * I = IHI 10 CONTINUE IF( I.LT.ILO ) $ GO TO 130 * * Perform QR iterations on rows and columns ILO to I until a * submatrix of order 1 splits off at the bottom because a * subdiagonal element has become negligible. * L = ILO DO 110 ITS = 0, ITN * * Look for a single small subdiagonal element. * DO 20 K = I, L + 1, -1 TST1 = CABS1( H( K-1, K-1 ) ) + CABS1( H( K, K ) ) IF( TST1.EQ.RZERO ) $ TST1 = ZLANHS( '1', I-L+1, H( L, L ), LDH, RWORK ) IF( ABS( DBLE( H( K, K-1 ) ) ).LE.MAX( ULP*TST1, SMLNUM ) ) $ GO TO 30 20 CONTINUE 30 CONTINUE L = K IF( L.GT.ILO ) THEN * * H(L,L-1) is negligible * H( L, L-1 ) = ZERO END IF * * Exit from loop if a submatrix of order 1 has split off. * IF( L.GE.I ) $ GO TO 120 * * Now the active submatrix is in rows and columns L to I. If * eigenvalues only are being computed, only the active submatrix * need be transformed. * IF( .NOT.WANTT ) THEN I1 = L I2 = I END IF * IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN * * Exceptional shift. * T = ABS( DBLE( H( I, I-1 ) ) ) + $ ABS( DBLE( H( I-1, I-2 ) ) ) ELSE * * Wilkinson's shift. * T = H( I, I ) U = H( I-1, I )*DBLE( H( I, I-1 ) ) IF( U.NE.ZERO ) THEN X = HALF*( H( I-1, I-1 )-T ) Y = SQRT( X*X+U ) IF( DBLE( X )*DBLE( Y )+DIMAG( X )*DIMAG( Y ).LT.RZERO ) $ Y = -Y T = T - ZLADIV( U, ( X+Y ) ) END IF END IF * * Look for two consecutive small subdiagonal elements. * DO 40 M = I - 1, L + 1, -1 * * Determine the effect of starting the single-shift QR * iteration at row M, and see if this would make H(M,M-1) * negligible. * H11 = H( M, M ) H22 = H( M+1, M+1 ) H11S = H11 - T H21 = H( M+1, M ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 H10 = H( M, M-1 ) TST1 = CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) IF( ABS( H10*H21 ).LE.ULP*TST1 ) $ GO TO 50 40 CONTINUE H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T H21 = H( L+1, L ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 50 CONTINUE * * Single-shift QR step * DO 100 K = M, I - 1 * * The first iteration of this loop determines a reflection G * from the vector V and applies it from left and right to H, * thus creating a nonzero bulge below the subdiagonal. * * Each subsequent iteration determines a reflection G to * restore the Hessenberg form in the (K-1)th column, and thus * chases the bulge one step toward the bottom of the active * submatrix. * * V(2) is always real before the call to ZLARFG, and hence * after the call T2 ( = T1*V(2) ) is also real. * IF( K.GT.M ) $ CALL ZCOPY( 2, H( K, K-1 ), 1, V, 1 ) CALL ZLARFG( 2, V( 1 ), V( 2 ), 1, T1 ) IF( K.GT.M ) THEN H( K, K-1 ) = V( 1 ) H( K+1, K-1 ) = ZERO END IF V2 = V( 2 ) T2 = DBLE( T1*V2 ) * * Apply G from the left to transform the rows of the matrix * in columns K to I2. * DO 60 J = K, I2 SUM = DCONJG( T1 )*H( K, J ) + T2*H( K+1, J ) H( K, J ) = H( K, J ) - SUM H( K+1, J ) = H( K+1, J ) - SUM*V2 60 CONTINUE * * Apply G from the right to transform the columns of the * matrix in rows I1 to min(K+2,I). * DO 70 J = I1, MIN( K+2, I ) SUM = T1*H( J, K ) + T2*H( J, K+1 ) H( J, K ) = H( J, K ) - SUM H( J, K+1 ) = H( J, K+1 ) - SUM*DCONJG( V2 ) 70 CONTINUE * IF( WANTZ ) THEN * * Accumulate transformations in the matrix Z * DO 80 J = ILOZ, IHIZ SUM = T1*Z( J, K ) + T2*Z( J, K+1 ) Z( J, K ) = Z( J, K ) - SUM Z( J, K+1 ) = Z( J, K+1 ) - SUM*DCONJG( V2 ) 80 CONTINUE END IF * IF( K.EQ.M .AND. M.GT.L ) THEN * * If the QR step was started at row M > L because two * consecutive small subdiagonals were found, then extra * scaling must be performed to ensure that H(M,M-1) remains * real. * TEMP = ONE - T1 TEMP = TEMP / ABS( TEMP ) H( M+1, M ) = H( M+1, M )*DCONJG( TEMP ) IF( M+2.LE.I ) $ H( M+2, M+1 ) = H( M+2, M+1 )*TEMP DO 90 J = M, I IF( J.NE.M+1 ) THEN IF( I2.GT.J ) $ CALL ZSCAL( I2-J, TEMP, H( J, J+1 ), LDH ) CALL ZSCAL( J-I1, DCONJG( TEMP ), H( I1, J ), 1 ) IF( WANTZ ) THEN CALL ZSCAL( NZ, DCONJG( TEMP ), $ Z( ILOZ, J ), 1 ) END IF END IF 90 CONTINUE END IF 100 CONTINUE * * Ensure that H(I,I-1) is real. * TEMP = H( I, I-1 ) IF( DIMAG( TEMP ).NE.RZERO ) THEN RTEMP = ABS( TEMP ) H( I, I-1 ) = RTEMP TEMP = TEMP / RTEMP IF( I2.GT.I ) $ CALL ZSCAL( I2-I, DCONJG( TEMP ), H( I, I+1 ), LDH ) CALL ZSCAL( I-I1, TEMP, H( I1, I ), 1 ) IF( WANTZ ) THEN CALL ZSCAL( NZ, TEMP, Z( ILOZ, I ), 1 ) END IF END IF * 110 CONTINUE * * Failure to converge in remaining number of iterations * INFO = I RETURN * 120 CONTINUE * * H(I,I-1) is negligible: one eigenvalue has converged. * W( I ) = H( I, I ) * * Decrement number of remaining iterations, and return to start of * the main loop with new value of I. * ITN = ITN - ITS I = L - 1 GO TO 10 * 130 CONTINUE RETURN * * End of ZLAHQR * END arpack-akloeckner-07/LAPACK/zlange.f0000644000175000017500000000770306153460177017075 0ustar andreasandreas DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, M, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANGE returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * complex matrix A. * * Description * =========== * * ZLANGE returns the value * * ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANGE as described * above. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. When M = 0, * ZLANGE is set to zero. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. When N = 0, * ZLANGE is set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The m by n matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(M,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= M when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( MIN( M, N ).EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, M VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, M SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, M WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, M WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, M VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL ZLASSQ( M, A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANGE = VALUE RETURN * * End of ZLANGE * END arpack-akloeckner-07/LAPACK/zlanhs.f0000644000175000017500000000766006153460177017116 0ustar andreasandreas DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER NORM INTEGER LDA, N * .. * .. Array Arguments .. DOUBLE PRECISION WORK( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLANHS returns the value of the one norm, or the Frobenius norm, or * the infinity norm, or the element of largest absolute value of a * Hessenberg matrix A. * * Description * =========== * * ZLANHS returns the value * * ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm' * ( * ( norm1(A), NORM = '1', 'O' or 'o' * ( * ( normI(A), NORM = 'I' or 'i' * ( * ( normF(A), NORM = 'F', 'f', 'E' or 'e' * * where norm1 denotes the one norm of a matrix (maximum column sum), * normI denotes the infinity norm of a matrix (maximum row sum) and * normF denotes the Frobenius norm of a matrix (square root of sum of * squares). Note that max(abs(A(i,j))) is not a matrix norm. * * Arguments * ========= * * NORM (input) CHARACTER*1 * Specifies the value to be returned in ZLANHS as described * above. * * N (input) INTEGER * The order of the matrix A. N >= 0. When N = 0, ZLANHS is * set to zero. * * A (input) COMPLEX*16 array, dimension (LDA,N) * The n by n upper Hessenberg matrix A; the part of A below the * first sub-diagonal is not referenced. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(N,1). * * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), * where LWORK >= N when NORM = 'I'; otherwise, WORK is not * referenced. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION SCALE, SUM, VALUE * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL ZLASSQ * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. * .. Executable Statements .. * IF( N.EQ.0 ) THEN VALUE = ZERO ELSE IF( LSAME( NORM, 'M' ) ) THEN * * Find max(abs(A(i,j))). * VALUE = ZERO DO 20 J = 1, N DO 10 I = 1, MIN( N, J+1 ) VALUE = MAX( VALUE, ABS( A( I, J ) ) ) 10 CONTINUE 20 CONTINUE ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN * * Find norm1(A). * VALUE = ZERO DO 40 J = 1, N SUM = ZERO DO 30 I = 1, MIN( N, J+1 ) SUM = SUM + ABS( A( I, J ) ) 30 CONTINUE VALUE = MAX( VALUE, SUM ) 40 CONTINUE ELSE IF( LSAME( NORM, 'I' ) ) THEN * * Find normI(A). * DO 50 I = 1, N WORK( I ) = ZERO 50 CONTINUE DO 70 J = 1, N DO 60 I = 1, MIN( N, J+1 ) WORK( I ) = WORK( I ) + ABS( A( I, J ) ) 60 CONTINUE 70 CONTINUE VALUE = ZERO DO 80 I = 1, N VALUE = MAX( VALUE, WORK( I ) ) 80 CONTINUE ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN * * Find normF(A). * SCALE = ZERO SUM = ONE DO 90 J = 1, N CALL ZLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) 90 CONTINUE VALUE = SCALE*SQRT( SUM ) END IF * ZLANHS = VALUE RETURN * * End of ZLANHS * END arpack-akloeckner-07/LAPACK/zlarfg.f0000644000175000017500000000777206153460177017110 0ustar andreasandreas SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER INCX, N COMPLEX*16 ALPHA, TAU * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLARFG generates a complex elementary reflector H of order n, such * that * * H' * ( alpha ) = ( beta ), H' * H = I. * ( x ) ( 0 ) * * where alpha and beta are scalars, with beta real, and x is an * (n-1)-element complex vector. H is represented in the form * * H = I - tau * ( 1 ) * ( 1 v' ) , * ( v ) * * where tau is a complex scalar and v is a complex (n-1)-element * vector. Note that H is not hermitian. * * If the elements of x are all zero and alpha is real, then tau = 0 * and H is taken to be the unit matrix. * * Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . * * Arguments * ========= * * N (input) INTEGER * The order of the elementary reflector. * * ALPHA (input/output) COMPLEX*16 * On entry, the value alpha. * On exit, it is overwritten with the value beta. * * X (input/output) COMPLEX*16 array, dimension * (1+(N-2)*abs(INCX)) * On entry, the vector x. * On exit, it is overwritten with the vector v. * * INCX (input) INTEGER * The increment between elements of X. INCX > 0. * * TAU (output) COMPLEX*16 * The value tau. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER J, KNT DOUBLE PRECISION ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DLAPY3, DZNRM2 COMPLEX*16 ZLADIV EXTERNAL DLAMCH, DLAPY3, DZNRM2, ZLADIV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DIMAG, SIGN * .. * .. External Subroutines .. EXTERNAL ZDSCAL, ZSCAL * .. * .. Executable Statements .. * IF( N.LE.0 ) THEN TAU = ZERO RETURN END IF * XNORM = DZNRM2( N-1, X, INCX ) ALPHR = DBLE( ALPHA ) ALPHI = DIMAG( ALPHA ) * IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN * * H = I * TAU = ZERO ELSE * * general case * BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) RSAFMN = ONE / SAFMIN * IF( ABS( BETA ).LT.SAFMIN ) THEN * * XNORM, BETA may be inaccurate; scale X and recompute them * KNT = 0 10 CONTINUE KNT = KNT + 1 CALL ZDSCAL( N-1, RSAFMN, X, INCX ) BETA = BETA*RSAFMN ALPHI = ALPHI*RSAFMN ALPHR = ALPHR*RSAFMN IF( ABS( BETA ).LT.SAFMIN ) $ GO TO 10 * * New BETA is at most 1, at least SAFMIN * XNORM = DZNRM2( N-1, X, INCX ) ALPHA = DCMPLX( ALPHR, ALPHI ) BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR ) TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) * * If ALPHA is subnormal, it may lose relative accuracy * ALPHA = BETA DO 20 J = 1, KNT ALPHA = ALPHA*SAFMIN 20 CONTINUE ELSE TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA ) ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA ) CALL ZSCAL( N-1, ALPHA, X, INCX ) ALPHA = BETA END IF END IF * RETURN * * End of ZLARFG * END arpack-akloeckner-07/LAPACK/zlarnv.f0000644000175000017500000000773306153460200017117 0ustar andreasandreas SUBROUTINE ZLARNV( IDIST, ISEED, N, X ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. INTEGER IDIST, N * .. * .. Array Arguments .. INTEGER ISEED( 4 ) COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLARNV returns a vector of n random complex numbers from a uniform or * normal distribution. * * Arguments * ========= * * IDIST (input) INTEGER * Specifies the distribution of the random numbers: * = 1: real and imaginary parts each uniform (0,1) * = 2: real and imaginary parts each uniform (-1,1) * = 3: real and imaginary parts each normal (0,1) * = 4: uniformly distributed on the disc abs(z) < 1 * = 5: uniformly distributed on the circle abs(z) = 1 * * ISEED (input/output) INTEGER array, dimension (4) * On entry, the seed of the random number generator; the array * elements must be between 0 and 4095, and ISEED(4) must be * odd. * On exit, the seed is updated. * * N (input) INTEGER * The number of random numbers to be generated. * * X (output) COMPLEX*16 array, dimension (N) * The generated random numbers. * * Further Details * =============== * * This routine calls the auxiliary routine DLARUV to generate random * real numbers from a uniform (0,1) distribution, in batches of up to * 128 using vectorisable code. The Box-Muller method is used to * transform numbers from a uniform to a normal distribution. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE, TWO PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) INTEGER LV PARAMETER ( LV = 128 ) DOUBLE PRECISION TWOPI PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 ) * .. * .. Local Scalars .. INTEGER I, IL, IV * .. * .. Local Arrays .. DOUBLE PRECISION U( LV ) * .. * .. Intrinsic Functions .. INTRINSIC DCMPLX, EXP, LOG, MIN, SQRT * .. * .. External Subroutines .. EXTERNAL DLARUV * .. * .. Executable Statements .. * DO 60 IV = 1, N, LV / 2 IL = MIN( LV / 2, N-IV+1 ) * * Call DLARUV to generate 2*IL real numbers from a uniform (0,1) * distribution (2*IL <= LV) * CALL DLARUV( ISEED, 2*IL, U ) * IF( IDIST.EQ.1 ) THEN * * Copy generated numbers * DO 10 I = 1, IL X( IV+I-1 ) = DCMPLX( U( 2*I-1 ), U( 2*I ) ) 10 CONTINUE ELSE IF( IDIST.EQ.2 ) THEN * * Convert generated numbers to uniform (-1,1) distribution * DO 20 I = 1, IL X( IV+I-1 ) = DCMPLX( TWO*U( 2*I-1 )-ONE, $ TWO*U( 2*I )-ONE ) 20 CONTINUE ELSE IF( IDIST.EQ.3 ) THEN * * Convert generated numbers to normal (0,1) distribution * DO 30 I = 1, IL X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* $ EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) ) 30 CONTINUE ELSE IF( IDIST.EQ.4 ) THEN * * Convert generated numbers to complex numbers uniformly * distributed on the unit disk * DO 40 I = 1, IL X( IV+I-1 ) = SQRT( U( 2*I-1 ) )* $ EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) ) 40 CONTINUE ELSE IF( IDIST.EQ.5 ) THEN * * Convert generated numbers to complex numbers uniformly * distributed on the unit circle * DO 50 I = 1, IL X( IV+I-1 ) = EXP( DCMPLX( ZERO, TWOPI*U( 2*I ) ) ) 50 CONTINUE END IF 60 CONTINUE RETURN * * End of ZLARNV * END arpack-akloeckner-07/LAPACK/zlartg.f0000644000175000017500000000604206153460200017076 0ustar andreasandreas SUBROUTINE ZLARTG( F, G, CS, SN, R ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. DOUBLE PRECISION CS COMPLEX*16 F, G, R, SN * .. * * Purpose * ======= * * ZLARTG generates a plane rotation so that * * [ CS SN ] [ F ] [ R ] * [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. * [ -SN CS ] [ G ] [ 0 ] * * This is a faster version of the BLAS1 routine ZROTG, except for * the following differences: * F and G are unchanged on return. * If G=0, then CS=1 and SN=0. * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any * floating point operations. * * Arguments * ========= * * F (input) COMPLEX*16 * The first component of vector to be rotated. * * G (input) COMPLEX*16 * The second component of vector to be rotated. * * CS (output) DOUBLE PRECISION * The cosine of the rotation. * * SN (output) COMPLEX*16 * The sine of the rotation. * * R (output) COMPLEX*16 * The nonzero component of the rotated vector. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) COMPLEX*16 CZERO PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. DOUBLE PRECISION D, DI, F1, F2, FA, G1, G2, GA COMPLEX*16 FS, GS, SS, T * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCONJG, DIMAG, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION ABS1, ABSSQ * .. * .. Statement Function definitions .. ABS1( T ) = ABS( DBLE( T ) ) + ABS( DIMAG( T ) ) ABSSQ( T ) = DBLE( T )**2 + DIMAG( T )**2 * .. * .. Executable Statements .. * * [ 25 or 38 ops for main paths ] * IF( G.EQ.CZERO ) THEN CS = ONE SN = ZERO R = F ELSE IF( F.EQ.CZERO ) THEN CS = ZERO * SN = DCONJG( G ) / ABS( G ) R = ABS( G ) * * SN = ONE * R = G * ELSE F1 = ABS1( F ) G1 = ABS1( G ) IF( F1.GE.G1 ) THEN GS = G / F1 G2 = ABSSQ( GS ) FS = F / F1 F2 = ABSSQ( FS ) D = SQRT( ONE+G2 / F2 ) CS = ONE / D SN = DCONJG( GS )*FS*( CS / F2 ) R = F*D ELSE FS = F / G1 F2 = ABSSQ( FS ) FA = SQRT( F2 ) GS = G / G1 G2 = ABSSQ( GS ) GA = SQRT( G2 ) D = SQRT( ONE+F2 / G2 ) DI = ONE / D CS = ( FA / GA )*DI SS = ( DCONJG( GS )*FS ) / ( FA*GA ) SN = SS*DI R = G*SS*D END IF END IF RETURN * * End of ZLARTG * END arpack-akloeckner-07/LAPACK/zlascl.f0000644000175000017500000001622506153460200017067 0ustar andreasandreas SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER TYPE INTEGER INFO, KL, KU, LDA, M, N DOUBLE PRECISION CFROM, CTO * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASCL multiplies the M by N complex matrix A by the real scalar * CTO/CFROM. This is done without over/underflow as long as the final * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that * A may be full, upper triangular, lower triangular, upper Hessenberg, * or banded. * * Arguments * ========= * * TYPE (input) CHARACTER*1 * TYPE indices the storage type of the input matrix. * = 'G': A is a full matrix. * = 'L': A is a lower triangular matrix. * = 'U': A is an upper triangular matrix. * = 'H': A is an upper Hessenberg matrix. * = 'B': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the lower * half stored. * = 'Q': A is a symmetric band matrix with lower bandwidth KL * and upper bandwidth KU and with the only the upper * half stored. * = 'Z': A is a band matrix with lower bandwidth KL and upper * bandwidth KU. * * KL (input) INTEGER * The lower bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * KU (input) INTEGER * The upper bandwidth of A. Referenced only if TYPE = 'B', * 'Q' or 'Z'. * * CFROM (input) DOUBLE PRECISION * CTO (input) DOUBLE PRECISION * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed * without over/underflow if the final result CTO*A(I,J)/CFROM * can be represented without over/underflow. CFROM must be * nonzero. * * M (input) INTEGER * The number of rows of the matrix A. M >= 0. * * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * * A (input/output) COMPLEX*16 array, dimension (LDA,M) * The matrix to be multiplied by CTO/CFROM. See TYPE for the * storage type. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * INFO (output) INTEGER * 0 - successful exit * <0 - if INFO = -i, the i-th argument had an illegal value. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. * .. Local Scalars .. LOGICAL DONE INTEGER I, ITYPE, J, K1, K2, K3, K4 DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH EXTERNAL LSAME, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN * .. * .. External Subroutines .. EXTERNAL XERBLA * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 * IF( LSAME( TYPE, 'G' ) ) THEN ITYPE = 0 ELSE IF( LSAME( TYPE, 'L' ) ) THEN ITYPE = 1 ELSE IF( LSAME( TYPE, 'U' ) ) THEN ITYPE = 2 ELSE IF( LSAME( TYPE, 'H' ) ) THEN ITYPE = 3 ELSE IF( LSAME( TYPE, 'B' ) ) THEN ITYPE = 4 ELSE IF( LSAME( TYPE, 'Q' ) ) THEN ITYPE = 5 ELSE IF( LSAME( TYPE, 'Z' ) ) THEN ITYPE = 6 ELSE ITYPE = -1 END IF * IF( ITYPE.EQ.-1 ) THEN INFO = -1 ELSE IF( CFROM.EQ.ZERO ) THEN INFO = -4 ELSE IF( M.LT.0 ) THEN INFO = -6 ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN INFO = -7 ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN INFO = -9 ELSE IF( ITYPE.GE.4 ) THEN IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN INFO = -2 ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) $ THEN INFO = -3 ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN INFO = -9 END IF END IF * IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLASCL', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 .OR. M.EQ.0 ) $ RETURN * * Get machine parameters * SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM * CFROMC = CFROM CTOC = CTO * 10 CONTINUE CFROM1 = CFROMC*SMLNUM CTO1 = CTOC / BIGNUM IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN MUL = SMLNUM DONE = .FALSE. CFROMC = CFROM1 ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN MUL = BIGNUM DONE = .FALSE. CTOC = CTO1 ELSE MUL = CTOC / CFROMC DONE = .TRUE. END IF * IF( ITYPE.EQ.0 ) THEN * * Full matrix * DO 30 J = 1, N DO 20 I = 1, M A( I, J ) = A( I, J )*MUL 20 CONTINUE 30 CONTINUE * ELSE IF( ITYPE.EQ.1 ) THEN * * Lower triangular matrix * DO 50 J = 1, N DO 40 I = J, M A( I, J ) = A( I, J )*MUL 40 CONTINUE 50 CONTINUE * ELSE IF( ITYPE.EQ.2 ) THEN * * Upper triangular matrix * DO 70 J = 1, N DO 60 I = 1, MIN( J, M ) A( I, J ) = A( I, J )*MUL 60 CONTINUE 70 CONTINUE * ELSE IF( ITYPE.EQ.3 ) THEN * * Upper Hessenberg matrix * DO 90 J = 1, N DO 80 I = 1, MIN( J+1, M ) A( I, J ) = A( I, J )*MUL 80 CONTINUE 90 CONTINUE * ELSE IF( ITYPE.EQ.4 ) THEN * * Lower half of a symmetric band matrix * K3 = KL + 1 K4 = N + 1 DO 110 J = 1, N DO 100 I = 1, MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 100 CONTINUE 110 CONTINUE * ELSE IF( ITYPE.EQ.5 ) THEN * * Upper half of a symmetric band matrix * K1 = KU + 2 K3 = KU + 1 DO 130 J = 1, N DO 120 I = MAX( K1-J, 1 ), K3 A( I, J ) = A( I, J )*MUL 120 CONTINUE 130 CONTINUE * ELSE IF( ITYPE.EQ.6 ) THEN * * Band matrix * K1 = KL + KU + 2 K2 = KL + 1 K3 = 2*KL + KU + 1 K4 = KL + KU + 1 + M DO 150 J = 1, N DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) A( I, J ) = A( I, J )*MUL 140 CONTINUE 150 CONTINUE * END IF * IF( .NOT.DONE ) $ GO TO 10 * RETURN * * End of ZLASCL * END arpack-akloeckner-07/LAPACK/zlaset.f0000644000175000017500000000607206153460201017101 0ustar andreasandreas SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. CHARACTER UPLO INTEGER LDA, M, N COMPLEX*16 ALPHA, BETA * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASET initializes a 2-D array A to BETA on the diagonal and * ALPHA on the offdiagonals. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies the part of the matrix A to be set. * = 'U': Upper triangular part is set. The lower triangle * is unchanged. * = 'L': Lower triangular part is set. The upper triangle * is unchanged. * Otherwise: All of the matrix A is set. * * M (input) INTEGER * On entry, M specifies the number of rows of A. * * N (input) INTEGER * On entry, N specifies the number of columns of A. * * ALPHA (input) COMPLEX*16 * All the offdiagonal array elements are set to ALPHA. * * BETA (input) COMPLEX*16 * All the diagonal array elements are set to BETA. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the m by n matrix A. * On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; * A(i,i) = BETA , 1 <= i <= min(m,n) * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * ===================================================================== * * .. Local Scalars .. INTEGER I, J * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC MIN * .. * .. Executable Statements .. * IF( LSAME( UPLO, 'U' ) ) THEN * * Set the diagonal to BETA and the strictly upper triangular * part of the array to ALPHA. * DO 20 J = 2, N DO 10 I = 1, MIN( J-1, M ) A( I, J ) = ALPHA 10 CONTINUE 20 CONTINUE DO 30 I = 1, MIN( N, M ) A( I, I ) = BETA 30 CONTINUE * ELSE IF( LSAME( UPLO, 'L' ) ) THEN * * Set the diagonal to BETA and the strictly lower triangular * part of the array to ALPHA. * DO 50 J = 1, MIN( M, N ) DO 40 I = J + 1, M A( I, J ) = ALPHA 40 CONTINUE 50 CONTINUE DO 60 I = 1, MIN( N, M ) A( I, I ) = BETA 60 CONTINUE * ELSE * * Set the array to BETA on the diagonal and ALPHA on the * offdiagonal. * DO 80 J = 1, N DO 70 I = 1, M A( I, J ) = ALPHA 70 CONTINUE 80 CONTINUE DO 90 I = 1, MIN( M, N ) A( I, I ) = BETA 90 CONTINUE END IF * RETURN * * End of ZLASET * END arpack-akloeckner-07/LAPACK/zlassq.f0000644000175000017500000000600206153460201017105 0ustar andreasandreas SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, N DOUBLE PRECISION SCALE, SUMSQ * .. * .. Array Arguments .. COMPLEX*16 X( * ) * .. * * Purpose * ======= * * ZLASSQ returns the values scl and ssq such that * * ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, * * where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is * assumed to be at least unity and the value of ssq will then satisfy * * 1.0 .le. ssq .le. ( sumsq + 2*n ). * * scale is assumed to be non-negative and scl returns the value * * scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), * i * * scale and sumsq must be supplied in SCALE and SUMSQ respectively. * SCALE and SUMSQ are overwritten by scl and ssq respectively. * * The routine makes only one pass through the vector X. * * Arguments * ========= * * N (input) INTEGER * The number of elements to be used from the vector X. * * X (input) DOUBLE PRECISION * The vector x as described above. * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. * * INCX (input) INTEGER * The increment between successive values of the vector X. * INCX > 0. * * SCALE (input/output) DOUBLE PRECISION * On entry, the value scale in the equation above. * On exit, SCALE is overwritten with the value scl . * * SUMSQ (input/output) DOUBLE PRECISION * On entry, the value sumsq in the equation above. * On exit, SUMSQ is overwritten with the value ssq . * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. * .. Local Scalars .. INTEGER IX DOUBLE PRECISION TEMP1 * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG * .. * .. Executable Statements .. * IF( N.GT.0 ) THEN DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX IF( DBLE( X( IX ) ).NE.ZERO ) THEN TEMP1 = ABS( DBLE( X( IX ) ) ) IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF IF( DIMAG( X( IX ) ).NE.ZERO ) THEN TEMP1 = ABS( DIMAG( X( IX ) ) ) IF( SCALE.LT.TEMP1 ) THEN SUMSQ = 1 + SUMSQ*( SCALE / TEMP1 )**2 SCALE = TEMP1 ELSE SUMSQ = SUMSQ + ( TEMP1 / SCALE )**2 END IF END IF 10 CONTINUE END IF * RETURN * * End of ZLASSQ * END arpack-akloeckner-07/LAPACK/zlaswp.f0000644000175000017500000000542306153460201017116 0ustar andreasandreas SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, K1, K2, LDA, N * .. * .. Array Arguments .. INTEGER IPIV( * ) COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * * ZLASWP performs a series of row interchanges on the matrix A. * One row interchange is initiated for each of rows K1 through K2 of A. * * Arguments * ========= * * N (input) INTEGER * The number of columns of the matrix A. * * A (input/output) COMPLEX*16 array, dimension (LDA,N) * On entry, the matrix of column dimension N to which the row * interchanges will be applied. * On exit, the permuted matrix. * * LDA (input) INTEGER * The leading dimension of the array A. * * K1 (input) INTEGER * The first element of IPIV for which a row interchange will * be done. * * K2 (input) INTEGER * The last element of IPIV for which a row interchange will * be done. * * IPIV (input) INTEGER array, dimension (M*abs(INCX)) * The vector of pivot indices. Only the elements in positions * K1 through K2 of IPIV are accessed. * IPIV(K) = L implies rows K and L are to be interchanged. * * INCX (input) INTEGER * The increment between successive values of IPIV. If IPIV * is negative, the pivots are applied in reverse order. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IP, IX * .. * .. External Subroutines .. EXTERNAL ZSWAP * .. * .. Executable Statements .. * * Interchange row I with row IPIV(I) for each of rows K1 through K2. * IF( INCX.EQ.0 ) $ RETURN IF( INCX.GT.0 ) THEN IX = K1 ELSE IX = 1 + ( 1-K2 )*INCX END IF IF( INCX.EQ.1 ) THEN DO 10 I = K1, K2 IP = IPIV( I ) IF( IP.NE.I ) $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) 10 CONTINUE ELSE IF( INCX.GT.1 ) THEN DO 20 I = K1, K2 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 20 CONTINUE ELSE IF( INCX.LT.0 ) THEN DO 30 I = K2, K1, -1 IP = IPIV( IX ) IF( IP.NE.I ) $ CALL ZSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) IX = IX + INCX 30 CONTINUE END IF * RETURN * * End of ZLASWP * END arpack-akloeckner-07/LAPACK/zlatrs.f0000644000175000017500000006633106153460201017122 0ustar andreasandreas SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * June 30, 1992 * * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER INFO, LDA, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. DOUBLE PRECISION CNORM( * ) COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZLATRS solves one of the triangular systems * * A * x = s*b, A**T * x = s*b, or A**H * x = s*b, * * with scaling to prevent overflow. Here A is an upper or lower * triangular matrix, A**T denotes the transpose of A, A**H denotes the * conjugate transpose of A, x and b are n-element vectors, and s is a * scaling factor, usually less than or equal to 1, chosen so that the * components of x will be less than the overflow threshold. If the * unscaled problem will not cause overflow, the Level 2 BLAS routine * ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), * then s is set to 0 and a non-trivial solution to A*x = 0 is returned. * * Arguments * ========= * * UPLO (input) CHARACTER*1 * Specifies whether the matrix A is upper or lower triangular. * = 'U': Upper triangular * = 'L': Lower triangular * * TRANS (input) CHARACTER*1 * Specifies the operation applied to A. * = 'N': Solve A * x = s*b (No transpose) * = 'T': Solve A**T * x = s*b (Transpose) * = 'C': Solve A**H * x = s*b (Conjugate transpose) * * DIAG (input) CHARACTER*1 * Specifies whether or not the matrix A is unit triangular. * = 'N': Non-unit triangular * = 'U': Unit triangular * * NORMIN (input) CHARACTER*1 * Specifies whether CNORM has been set or not. * = 'Y': CNORM contains the column norms on entry * = 'N': CNORM is not set on entry. On exit, the norms will * be computed and stored in CNORM. * * N (input) INTEGER * The order of the matrix A. N >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,N) * 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. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max (1,N). * * X (input/output) COMPLEX*16 array, dimension (N) * On entry, the right hand side b of the triangular system. * On exit, X is overwritten by the solution vector x. * * SCALE (output) DOUBLE PRECISION * The scaling factor s for the triangular system * A * x = s*b, A**T * x = s*b, or A**H * x = s*b. * If SCALE = 0, the matrix A is singular or badly scaled, and * the vector x is an exact or approximate solution to A*x = 0. * * CNORM (input or output) DOUBLE PRECISION array, dimension (N) * * If NORMIN = 'Y', CNORM is an input argument and CNORM(j) * contains the norm of the off-diagonal part of the j-th column * of A. If TRANS = 'N', CNORM(j) must be greater than or equal * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) * must be greater than or equal to the 1-norm. * * If NORMIN = 'N', CNORM is an output argument and CNORM(j) * returns the 1-norm of the offdiagonal part of the j-th column * of A. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -k, the k-th argument had an illegal value * * Further Details * ======= ======= * * A rough bound on x is computed; if that is less than overflow, ZTRSV * is called, otherwise, specific code is used which checks for possible * overflow or divide-by-zero at every operation. * * A columnwise scheme is used for solving A*x = b. The basic algorithm * if A is lower triangular is * * x[1:n] := b[1:n] * for j = 1, ..., n * x(j) := x(j) / A(j,j) * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] * end * * Define bounds on the components of x after j iterations of the loop: * M(j) = bound on x[1:j] * G(j) = bound on x[j+1:n] * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. * * Then for iteration j+1 we have * M(j+1) <= G(j) / | A(j+1,j+1) | * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) * * where CNORM(j+1) is greater than or equal to the infinity-norm of * column j+1 of A, not counting the diagonal. Hence * * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) * 1<=i<=j * and * * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) * 1<=i< j * * Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the * reciprocal of the largest M(j), j=1,..,n, is larger than * max(underflow, 1/overflow). * * The bound on x(j) is also used to determine when a step in the * columnwise method can be performed without fear of overflow. If * the computed bound is greater than a large constant, x is scaled to * prevent overflow, but if the bound overflows, x is set to 0, x(j) to * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. * * Similarly, a row-wise scheme is used to solve A**T *x = b or * A**H *x = b. The basic algorithm for A upper triangular is * * for j = 1, ..., n * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) * end * * We simultaneously compute two bounds * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j * M(j) = bound on x(i), 1<=i<=j * * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. * Then the bound on x(j) is * * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | * * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) * 1<=i<=j * * and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater * than max(underflow, 1/overflow). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE, TWO PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, $ TWO = 2.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRAN, NOUNIT, UPPER INTEGER I, IMAX, J, JFIRST, JINC, JLAST DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, TJJ, TMAX, TSCAL, $ XBND, XJ, XMAX COMPLEX*16 CSUMJ, TJJS, USCAL, ZDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IDAMAX, IZAMAX DOUBLE PRECISION DLAMCH, DZASUM COMPLEX*16 ZDOTC, ZDOTU, ZLADIV EXTERNAL LSAME, IDAMAX, IZAMAX, DLAMCH, DZASUM, ZDOTC, $ ZDOTU, ZLADIV * .. * .. External Subroutines .. EXTERNAL DLABAD, DSCAL, XERBLA, ZAXPY, ZDSCAL, ZTRSV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN * .. * .. Statement Functions .. DOUBLE PRECISION CABS1, CABS2 * .. * .. Statement Function definitions .. CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) CABS2( ZDUM ) = ABS( DBLE( ZDUM ) / 2.D0 ) + $ ABS( DIMAG( ZDUM ) / 2.D0 ) * .. * .. Executable Statements .. * INFO = 0 UPPER = LSAME( UPLO, 'U' ) NOTRAN = LSAME( TRANS, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) * * Test the input parameters. * IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. $ LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN INFO = -3 ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. $ LSAME( NORMIN, 'N' ) ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, N ) ) THEN INFO = -7 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZLATRS', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.0 ) $ RETURN * * Determine machine dependent parameters to control overflow. * SMLNUM = DLAMCH( 'Safe minimum' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM / DLAMCH( 'Precision' ) BIGNUM = ONE / SMLNUM SCALE = ONE * IF( LSAME( NORMIN, 'N' ) ) THEN * * Compute the 1-norm of each column, not including the diagonal. * IF( UPPER ) THEN * * A is upper triangular. * DO 10 J = 1, N CNORM( J ) = DZASUM( J-1, A( 1, J ), 1 ) 10 CONTINUE ELSE * * A is lower triangular. * DO 20 J = 1, N - 1 CNORM( J ) = DZASUM( N-J, A( J+1, J ), 1 ) 20 CONTINUE CNORM( N ) = ZERO END IF END IF * * Scale the column norms by TSCAL if the maximum element in CNORM is * greater than BIGNUM/2. * IMAX = IDAMAX( N, CNORM, 1 ) TMAX = CNORM( IMAX ) IF( TMAX.LE.BIGNUM*HALF ) THEN TSCAL = ONE ELSE TSCAL = HALF / ( SMLNUM*TMAX ) CALL DSCAL( N, TSCAL, CNORM, 1 ) END IF * * Compute a bound on the computed solution vector to see if the * Level 2 BLAS routine ZTRSV can be used. * XMAX = ZERO DO 30 J = 1, N XMAX = MAX( XMAX, CABS2( X( J ) ) ) 30 CONTINUE XBND = XMAX * IF( NOTRAN ) THEN * * Compute the growth in A * x = b. * IF( UPPER ) THEN JFIRST = N JLAST = 1 JINC = -1 ELSE JFIRST = 1 JLAST = N JINC = 1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 60 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, G(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 40 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = G(j-1) / abs(A(j,j)) * XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF * IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN * * G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) * GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) ELSE * * G(j) could overflow, set GROW to 0. * GROW = ZERO END IF 40 CONTINUE GROW = XBND ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 50 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 60 * * G(j) = G(j-1)*( 1 + CNORM(j) ) * GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) 50 CONTINUE END IF 60 CONTINUE * ELSE * * Compute the growth in A**T * x = b or A**H * x = b. * IF( UPPER ) THEN JFIRST = 1 JLAST = N JINC = 1 ELSE JFIRST = N JLAST = 1 JINC = -1 END IF * IF( TSCAL.NE.ONE ) THEN GROW = ZERO GO TO 90 END IF * IF( NOUNIT ) THEN * * A is non-unit triangular. * * Compute GROW = 1/G(j) and XBND = 1/M(j). * Initially, M(0) = max{x(i), i=1,...,n}. * GROW = HALF / MAX( XBND, SMLNUM ) XBND = GROW DO 70 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) * XJ = ONE + CNORM( J ) GROW = MIN( GROW, XBND / XJ ) * TJJS = A( J, J ) TJJ = CABS1( TJJS ) * IF( TJJ.GE.SMLNUM ) THEN * * M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) * IF( XJ.GT.TJJ ) $ XBND = XBND*( TJJ / XJ ) ELSE * * M(j) could overflow, set XBND to 0. * XBND = ZERO END IF 70 CONTINUE GROW = MIN( GROW, XBND ) ELSE * * A is unit triangular. * * Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. * GROW = MIN( ONE, HALF / MAX( XBND, SMLNUM ) ) DO 80 J = JFIRST, JLAST, JINC * * Exit the loop if the growth factor is too small. * IF( GROW.LE.SMLNUM ) $ GO TO 90 * * G(j) = ( 1 + CNORM(j) )*G(j-1) * XJ = ONE + CNORM( J ) GROW = GROW / XJ 80 CONTINUE END IF 90 CONTINUE END IF * IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN * * Use the Level 2 BLAS solve if the reciprocal of the bound on * elements of X is not too small. * CALL ZTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) ELSE * * Use a Level 1 BLAS solve, scaling intermediate results. * IF( XMAX.GT.BIGNUM*HALF ) THEN * * Scale X so that its components are less than or equal to * BIGNUM in absolute value. * SCALE = ( BIGNUM*HALF ) / XMAX CALL ZDSCAL( N, SCALE, X, 1 ) XMAX = BIGNUM ELSE XMAX = XMAX*TWO END IF * IF( NOTRAN ) THEN * * Solve A * x = b * DO 120 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) / A(j,j), scaling x if necessary. * XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 110 END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by 1/b(j). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM * to avoid overflow when dividing by A(j,j). * REC = ( TJJ*BIGNUM ) / XJ IF( CNORM( J ).GT.ONE ) THEN * * Scale by 1/CNORM(j) to avoid overflow when * multiplying x(j) times column j. * REC = REC / CNORM( J ) END IF CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) XJ = CABS1( X( J ) ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0, and compute a solution to A*x = 0. * DO 100 I = 1, N X( I ) = ZERO 100 CONTINUE X( J ) = ONE XJ = ONE SCALE = ZERO XMAX = ZERO END IF 110 CONTINUE * * Scale x if necessary to avoid overflow when adding a * multiple of column j of A. * IF( XJ.GT.ONE ) THEN REC = ONE / XJ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN * * Scale x by 1/(2*abs(x(j))). * REC = REC*HALF CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC END IF ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN * * Scale x by 1/2. * CALL ZDSCAL( N, HALF, X, 1 ) SCALE = SCALE*HALF END IF * IF( UPPER ) THEN IF( J.GT.1 ) THEN * * Compute the update * x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) * CALL ZAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, $ 1 ) I = IZAMAX( J-1, X, 1 ) XMAX = CABS1( X( I ) ) END IF ELSE IF( J.LT.N ) THEN * * Compute the update * x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) * CALL ZAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, $ X( J+1 ), 1 ) I = J + IZAMAX( N-J, X( J+1 ), 1 ) XMAX = CABS1( X( I ) ) END IF END IF 120 CONTINUE * ELSE IF( LSAME( TRANS, 'T' ) ) THEN * * Solve A**T * x = b * DO 170 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = ZLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.DCMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call ZDOTU to perform the dot product. * IF( UPPER ) THEN CSUMJ = ZDOTU( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = ZDOTU( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 130 I = 1, J - 1 CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 130 CONTINUE ELSE IF( J.LT.N ) THEN DO 140 I = J + 1, N CSUMJ = CSUMJ + ( A( I, J )*USCAL )*X( I ) 140 CONTINUE END IF END IF * IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = A( J, J )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 160 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**T *x = 0. * DO 150 I = 1, N X( I ) = ZERO 150 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 160 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 170 CONTINUE * ELSE * * Solve A**H * x = b * DO 220 J = JFIRST, JLAST, JINC * * Compute x(j) = b(j) - sum A(k,j)*x(k). * k<>j * XJ = CABS1( X( J ) ) USCAL = TSCAL REC = ONE / MAX( XMAX, ONE ) IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN * * If x(j) could overflow, scale x by 1/(2*XMAX). * REC = REC*HALF IF( NOUNIT ) THEN TJJS = DCONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL END IF TJJ = CABS1( TJJS ) IF( TJJ.GT.ONE ) THEN * * Divide by A(j,j) when scaling x if A(j,j) > 1. * REC = MIN( ONE, REC*TJJ ) USCAL = ZLADIV( USCAL, TJJS ) END IF IF( REC.LT.ONE ) THEN CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF * CSUMJ = ZERO IF( USCAL.EQ.DCMPLX( ONE ) ) THEN * * If the scaling needed for A in the dot product is 1, * call ZDOTC to perform the dot product. * IF( UPPER ) THEN CSUMJ = ZDOTC( J-1, A( 1, J ), 1, X, 1 ) ELSE IF( J.LT.N ) THEN CSUMJ = ZDOTC( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) END IF ELSE * * Otherwise, use in-line code for the dot product. * IF( UPPER ) THEN DO 180 I = 1, J - 1 CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* $ X( I ) 180 CONTINUE ELSE IF( J.LT.N ) THEN DO 190 I = J + 1, N CSUMJ = CSUMJ + ( DCONJG( A( I, J ) )*USCAL )* $ X( I ) 190 CONTINUE END IF END IF * IF( USCAL.EQ.DCMPLX( TSCAL ) ) THEN * * Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) * was not used to scale the dotproduct. * X( J ) = X( J ) - CSUMJ XJ = CABS1( X( J ) ) IF( NOUNIT ) THEN TJJS = DCONJG( A( J, J ) )*TSCAL ELSE TJJS = TSCAL IF( TSCAL.EQ.ONE ) $ GO TO 210 END IF * * Compute x(j) = x(j) / A(j,j), scaling if necessary. * TJJ = CABS1( TJJS ) IF( TJJ.GT.SMLNUM ) THEN * * abs(A(j,j)) > SMLNUM: * IF( TJJ.LT.ONE ) THEN IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale X by 1/abs(x(j)). * REC = ONE / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE IF( TJJ.GT.ZERO ) THEN * * 0 < abs(A(j,j)) <= SMLNUM: * IF( XJ.GT.TJJ*BIGNUM ) THEN * * Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. * REC = ( TJJ*BIGNUM ) / XJ CALL ZDSCAL( N, REC, X, 1 ) SCALE = SCALE*REC XMAX = XMAX*REC END IF X( J ) = ZLADIV( X( J ), TJJS ) ELSE * * A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and * scale = 0 and compute a solution to A**H *x = 0. * DO 200 I = 1, N X( I ) = ZERO 200 CONTINUE X( J ) = ONE SCALE = ZERO XMAX = ZERO END IF 210 CONTINUE ELSE * * Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot * product has already been divided by 1/A(j,j). * X( J ) = ZLADIV( X( J ), TJJS ) - CSUMJ END IF XMAX = MAX( XMAX, CABS1( X( J ) ) ) 220 CONTINUE END IF SCALE = SCALE / TSCAL END IF * * Scale the column norms by 1/TSCAL for return. * IF( TSCAL.NE.ONE ) THEN CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * RETURN * * End of ZLATRS * END arpack-akloeckner-07/LAPACK/zmach.f0000644000175000017500000000310006153460201016666 0ustar andreasandreas double precision function zmach(job) integer job c c double complex floating point arithmetic constants. c for the linpack test drivers only. c not used by actual linpack subroutines. c c smach computes machine parameters of floating point c arithmetic for use in testing only. not required by c linpack proper. c c if trouble with automatic computation of these quantities, c they can be set by direct assignment statements. c assume the computer has c c b = base of arithmetic c t = number of base b digits c l = smallest possible exponent c u = largest possible exponent c c then c c eps = b**(1-t) c tiny = 100.0*b**(-l+t) c huge = 0.01*b**(u-t) c c dmach same as smach except t, l, u apply to c double precision. c c cmach same as smach except if complex division c is done by c c 1/(x+i*y) = (x-i*y)/(x**2+y**2) c c then c c tiny = sqrt(tiny) c huge = sqrt(huge) c c c job is 1, 2 or 3 for epsilon, tiny and huge, respectively. c double precision eps,tiny,huge,s c eps = 1.0d0 10 eps = eps/2.0d0 s = 1.0d0 + eps if (s .gt. 1.0d0) go to 10 eps = 2.0d0*eps c s = 1.0d0 20 tiny = s s = s/16.0d0 if (s*1.0d0 .ne. 0.0d0) go to 20 tiny = tiny/eps s = (1.0d0,0.0d0)/dcmplx(tiny,0.0d0) if (s .ne. 1.0d0/tiny) tiny = dsqrt(tiny) huge = 1.0d0/tiny c if (job .eq. 1) zmach = eps if (job .eq. 2) zmach = tiny if (job .eq. 3) zmach = huge return end arpack-akloeckner-07/LAPACK/zrot.f0000644000175000017500000000470706153460201016600 0ustar andreasandreas SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * October 31, 1992 * * .. Scalar Arguments .. INTEGER INCX, INCY, N DOUBLE PRECISION C COMPLEX*16 S * .. * .. Array Arguments .. COMPLEX*16 CX( * ), CY( * ) * .. * * Purpose * ======= * * ZROT applies a plane rotation, where the cos (C) is real and the * sin (S) is complex, and the vectors CX and CY are complex. * * Arguments * ========= * * N (input) INTEGER * The number of elements in the vectors CX and CY. * * CX (input/output) COMPLEX*16 array, dimension (N) * On input, the vector X. * On output, CX is overwritten with C*X + S*Y. * * INCX (input) INTEGER * The increment between successive values of CY. INCX <> 0. * * CY (input/output) COMPLEX*16 array, dimension (N) * On input, the vector Y. * On output, CY is overwritten with -CONJG(S)*X + C*Y. * * INCY (input) INTEGER * The increment between successive values of CY. INCX <> 0. * * C (input) DOUBLE PRECISION * S (input) COMPLEX*16 * C and S define a rotation * [ C S ] * [ -conjg(S) C ] * where C*C + S*CONJG(S) = 1.0. * * ===================================================================== * * .. Local Scalars .. INTEGER I, IX, IY COMPLEX*16 STEMP * .. * .. Intrinsic Functions .. INTRINSIC DCONJG * .. * .. Executable Statements .. * IF( N.LE.0 ) $ RETURN IF( INCX.EQ.1 .AND. INCY.EQ.1 ) $ GO TO 20 * * Code for unequal increments or equal increments not equal to 1 * IX = 1 IY = 1 IF( INCX.LT.0 ) $ IX = ( -N+1 )*INCX + 1 IF( INCY.LT.0 ) $ IY = ( -N+1 )*INCY + 1 DO 10 I = 1, N STEMP = C*CX( IX ) + S*CY( IY ) CY( IY ) = C*CY( IY ) - DCONJG( S )*CX( IX ) CX( IX ) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * * Code for both increments equal to 1 * 20 CONTINUE DO 30 I = 1, N STEMP = C*CX( I ) + S*CY( I ) CY( I ) = C*CY( I ) - DCONJG( S )*CX( I ) CX( I ) = STEMP 30 CONTINUE RETURN END arpack-akloeckner-07/LAPACK/ztrevc.f0000644000175000017500000003040106153460202017106 0ustar andreasandreas SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, LDT, LDVL, LDVR, M, MM, N * .. * .. Array Arguments .. LOGICAL SELECT( * ) DOUBLE PRECISION RWORK( * ) COMPLEX*16 T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), $ WORK( * ) * .. * * Purpose * ======= * * ZTREVC computes some or all of the right and/or left eigenvectors of * a complex upper triangular matrix T. * * The right eigenvector x and the left eigenvector y of T corresponding * to an eigenvalue w are defined by: * * T*x = w*x, y'*T = w*y' * * where y' denotes the conjugate transpose of the vector y. * * If all eigenvectors are requested, the routine may either return the * matrices X and/or Y of right or left eigenvectors of T, or the * products Q*X and/or Q*Y, where Q is an input unitary * matrix. If T was obtained from the Schur factorization of an * original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of * right or left eigenvectors of A. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'R': compute right eigenvectors only; * = 'L': compute left eigenvectors only; * = 'B': compute both right and left eigenvectors. * * HOWMNY (input) CHARACTER*1 * = 'A': compute all right and/or left eigenvectors; * = 'B': compute all right and/or left eigenvectors, * and backtransform them using the input matrices * supplied in VR and/or VL; * = 'S': compute selected right and/or left eigenvectors, * specified by the logical array SELECT. * * SELECT (input) LOGICAL array, dimension (N) * If HOWMNY = 'S', SELECT specifies the eigenvectors to be * computed. * If HOWMNY = 'A' or 'B', SELECT is not referenced. * To select the eigenvector corresponding to the j-th * eigenvalue, SELECT(j) must be set to .TRUE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) COMPLEX*16 array, dimension (LDT,N) * The upper triangular matrix T. T is modified, but restored * on exit. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * VL (input/output) COMPLEX*16 array, dimension (LDVL,MM) * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must * contain an N-by-N matrix Q (usually the unitary matrix Q of * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'L' or 'B', VL contains: * if HOWMNY = 'A', the matrix Y of left eigenvectors of T; * if HOWMNY = 'B', the matrix Q*Y; * if HOWMNY = 'S', the left eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VL, in the same order as their * eigenvalues. * If SIDE = 'R', VL is not referenced. * * LDVL (input) INTEGER * The leading dimension of the array VL. LDVL >= max(1,N) if * SIDE = 'L' or 'B'; LDVL >= 1 otherwise. * * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM) * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must * contain an N-by-N matrix Q (usually the unitary matrix Q of * Schur vectors returned by ZHSEQR). * On exit, if SIDE = 'R' or 'B', VR contains: * if HOWMNY = 'A', the matrix X of right eigenvectors of T; * if HOWMNY = 'B', the matrix Q*X; * if HOWMNY = 'S', the right eigenvectors of T specified by * SELECT, stored consecutively in the columns * of VR, in the same order as their * eigenvalues. * If SIDE = 'L', VR is not referenced. * * LDVR (input) INTEGER * The leading dimension of the array VR. LDVR >= max(1,N) if * SIDE = 'R' or 'B'; LDVR >= 1 otherwise. * * MM (input) INTEGER * The number of columns in the arrays VL and/or VR. MM >= M. * * M (output) INTEGER * The number of columns in the arrays VL and/or VR actually * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M * is set to N. Each selected eigenvector occupies one * column. * * WORK (workspace) COMPLEX*16 array, dimension (2*N) * * RWORK (workspace) DOUBLE PRECISION array, dimension (N) * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * The algorithm used in this program is basically backward (forward) * substitution, with scaling to make the the code robust against * possible overflow. * * Each eigenvector is normalized so that the element of largest * magnitude has magnitude 1; here the magnitude of a complex number * (x,y) is taken to be |x| + |y|. * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) COMPLEX*16 CMZERO, CMONE PARAMETER ( CMZERO = ( 0.0D+0, 0.0D+0 ), $ CMONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL ALLV, BOTHV, LEFTV, OVER, RIGHTV, SOMEV INTEGER I, II, IS, J, K, KI DOUBLE PRECISION OVFL, REMAX, SCALE, SMIN, SMLNUM, ULP, UNFL COMPLEX*16 CDUM * .. * .. External Functions .. LOGICAL LSAME INTEGER IZAMAX DOUBLE PRECISION DLAMCH, DZASUM EXTERNAL LSAME, IZAMAX, DLAMCH, DZASUM * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZLATRS * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 * .. * .. Statement Function definitions .. CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) * .. * .. Executable Statements .. * * Decode and test the input parameters * BOTHV = LSAME( SIDE, 'B' ) RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV * ALLV = LSAME( HOWMNY, 'A' ) OVER = LSAME( HOWMNY, 'B' ) .OR. LSAME( HOWMNY, 'O' ) SOMEV = LSAME( HOWMNY, 'S' ) * * Set M to the number of columns required to store the selected * eigenvectors. * IF( SOMEV ) THEN M = 0 DO 10 J = 1, N IF( SELECT( J ) ) $ M = M + 1 10 CONTINUE ELSE M = N END IF * INFO = 0 IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN INFO = -1 ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN INFO = -8 ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN INFO = -10 ELSE IF( MM.LT.M ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTREVC', -INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * * Set the constants to control overflow. * UNFL = DLAMCH( 'Safe minimum' ) OVFL = ONE / UNFL CALL DLABAD( UNFL, OVFL ) ULP = DLAMCH( 'Precision' ) SMLNUM = UNFL*( N / ULP ) * * Store the diagonal elements of T in working array WORK. * DO 20 I = 1, N WORK( I+N ) = T( I, I ) 20 CONTINUE * * Compute 1-norm of each column of strictly upper triangular * part of T to control overflow in triangular solver. * RWORK( 1 ) = ZERO DO 30 J = 2, N RWORK( J ) = DZASUM( J-1, T( 1, J ), 1 ) 30 CONTINUE * IF( RIGHTV ) THEN * * Compute right eigenvectors. * IS = M DO 80 KI = N, 1, -1 * IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 80 END IF SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) * WORK( 1 ) = CMONE * * Form right-hand side. * DO 40 K = 1, KI - 1 WORK( K ) = -T( K, KI ) 40 CONTINUE * * Solve the triangular system: * (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK. * DO 50 K = 1, KI - 1 T( K, K ) = T( K, K ) - T( KI, KI ) IF( CABS1( T( K, K ) ).LT.SMIN ) $ T( K, K ) = SMIN 50 CONTINUE * IF( KI.GT.1 ) THEN CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', 'Y', $ KI-1, T, LDT, WORK( 1 ), SCALE, RWORK, $ INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VR and normalize. * IF( .NOT.OVER ) THEN CALL ZCOPY( KI, WORK( 1 ), 1, VR( 1, IS ), 1 ) * II = IZAMAX( KI, VR( 1, IS ), 1 ) REMAX = ONE / CABS1( VR( II, IS ) ) CALL ZDSCAL( KI, REMAX, VR( 1, IS ), 1 ) * DO 60 K = KI + 1, N VR( K, IS ) = CMZERO 60 CONTINUE ELSE IF( KI.GT.1 ) $ CALL ZGEMV( 'N', N, KI-1, CMONE, VR, LDVR, WORK( 1 ), $ 1, DCMPLX( SCALE ), VR( 1, KI ), 1 ) * II = IZAMAX( N, VR( 1, KI ), 1 ) REMAX = ONE / CABS1( VR( II, KI ) ) CALL ZDSCAL( N, REMAX, VR( 1, KI ), 1 ) END IF * * Set back the original diagonal elements of T. * DO 70 K = 1, KI - 1 T( K, K ) = WORK( K+N ) 70 CONTINUE * IS = IS - 1 80 CONTINUE END IF * IF( LEFTV ) THEN * * Compute left eigenvectors. * IS = 1 DO 130 KI = 1, N * IF( SOMEV ) THEN IF( .NOT.SELECT( KI ) ) $ GO TO 130 END IF SMIN = MAX( ULP*( CABS1( T( KI, KI ) ) ), SMLNUM ) * WORK( N ) = CMONE * * Form right-hand side. * DO 90 K = KI + 1, N WORK( K ) = -DCONJG( T( KI, K ) ) 90 CONTINUE * * Solve the triangular system: * (T(KI+1:N,KI+1:N) - T(KI,KI))'*X = SCALE*WORK. * DO 100 K = KI + 1, N T( K, K ) = T( K, K ) - T( KI, KI ) IF( CABS1( T( K, K ) ).LT.SMIN ) $ T( K, K ) = SMIN 100 CONTINUE * IF( KI.LT.N ) THEN CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', $ 'Y', N-KI, T( KI+1, KI+1 ), LDT, $ WORK( KI+1 ), SCALE, RWORK, INFO ) WORK( KI ) = SCALE END IF * * Copy the vector x or Q*x to VL and normalize. * IF( .NOT.OVER ) THEN CALL ZCOPY( N-KI+1, WORK( KI ), 1, VL( KI, IS ), 1 ) * II = IZAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1 REMAX = ONE / CABS1( VL( II, IS ) ) CALL ZDSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 ) * DO 110 K = 1, KI - 1 VL( K, IS ) = CMZERO 110 CONTINUE ELSE IF( KI.LT.N ) $ CALL ZGEMV( 'N', N, N-KI, CMONE, VL( 1, KI+1 ), LDVL, $ WORK( KI+1 ), 1, DCMPLX( SCALE ), $ VL( 1, KI ), 1 ) * II = IZAMAX( N, VL( 1, KI ), 1 ) REMAX = ONE / CABS1( VL( II, KI ) ) CALL ZDSCAL( N, REMAX, VL( 1, KI ), 1 ) END IF * * Set back the original diagonal elements of T. * DO 120 K = KI + 1, N T( K, K ) = WORK( K+N ) 120 CONTINUE * IS = IS + 1 130 CONTINUE END IF * RETURN * * End of ZTREVC * END arpack-akloeckner-07/LAPACK/ztrexc.f0000644000175000017500000001101106153460202017104 0ustar andreasandreas SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER COMPQ INTEGER IFST, ILST, INFO, LDQ, LDT, N * .. * .. Array Arguments .. COMPLEX*16 Q( LDQ, * ), T( LDT, * ) * .. * * Purpose * ======= * * ZTREXC reorders the Schur factorization of a complex matrix * A = Q*T*Q**H, so that the diagonal element of T with row index IFST * is moved to row ILST. * * The Schur form T is reordered by a unitary similarity transformation * Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by * postmultplying it with Z. * * Arguments * ========= * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) COMPLEX*16 array, dimension (LDT,N) * On entry, the upper triangular matrix T. * On exit, the reordered upper triangular matrix. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) COMPLEX*16 array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * unitary transformation matrix Z which reorders T. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. LDQ >= max(1,N). * * IFST (input) INTEGER * ILST (input) INTEGER * Specify the reordering of the diagonal elements of T: * The element with row index IFST is moved to row ILST by a * sequence of transpositions between adjacent elements. * 1 <= IFST <= N; 1 <= ILST <= N. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Local Scalars .. LOGICAL WANTQ INTEGER K, M1, M2, M3 DOUBLE PRECISION CS COMPLEX*16 SN, T11, T22, TEMP * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARTG, ZROT * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Decode and test the input parameters. * INFO = 0 WANTQ = LSAME( COMPQ, 'V' ) IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -1 ELSE IF( N.LT.0 ) THEN INFO = -2 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -4 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN INFO = -6 ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN INFO = -7 ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN INFO = -8 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTREXC', -INFO ) RETURN END IF * * Quick return if possible * IF( N.EQ.1 .OR. IFST.EQ.ILST ) $ RETURN * IF( IFST.LT.ILST ) THEN * * Move the IFST-th diagonal element forward down the diagonal. * M1 = 0 M2 = -1 M3 = 1 ELSE * * Move the IFST-th diagonal element backward up the diagonal. * M1 = -1 M2 = 0 M3 = -1 END IF * DO 10 K = IFST + M1, ILST + M2, M3 * * Interchange the k-th and (k+1)-th diagonal elements. * T11 = T( K, K ) T22 = T( K+1, K+1 ) * * Determine the transformation to perform the interchange. * CALL ZLARTG( T( K, K+1 ), T22-T11, CS, SN, TEMP ) * * Apply transformation to the matrix T. * IF( K+2.LE.N ) $ CALL ZROT( N-K-1, T( K, K+2 ), LDT, T( K+1, K+2 ), LDT, CS, $ SN ) CALL ZROT( K-1, T( 1, K ), 1, T( 1, K+1 ), 1, CS, $ DCONJG( SN ) ) * T( K, K ) = T22 T( K+1, K+1 ) = T11 * IF( WANTQ ) THEN * * Accumulate transformation in the matrix Q. * CALL ZROT( N, Q( 1, K ), 1, Q( 1, K+1 ), 1, CS, $ DCONJG( SN ) ) END IF * 10 CONTINUE * RETURN * * End of ZTREXC * END arpack-akloeckner-07/LAPACK/ztrsen.f0000644000175000017500000002523206153460202017124 0ustar andreasandreas SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER COMPQ, JOB INTEGER INFO, LDQ, LDT, LWORK, M, N DOUBLE PRECISION S, SEP * .. * .. Array Arguments .. LOGICAL SELECT( * ) COMPLEX*16 Q( LDQ, * ), T( LDT, * ), W( * ), WORK( * ) * .. * * Purpose * ======= * * ZTRSEN reorders the Schur factorization of a complex matrix * A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in * the leading positions on the diagonal of the upper triangular matrix * T, and the leading columns of Q form an orthonormal basis of the * corresponding right invariant subspace. * * Optionally the routine computes the reciprocal condition numbers of * the cluster of eigenvalues and/or the invariant subspace. * * Arguments * ========= * * JOB (input) CHARACTER*1 * Specifies whether condition numbers are required for the * cluster of eigenvalues (S) or the invariant subspace (SEP): * = 'N': none; * = 'E': for eigenvalues only (S); * = 'V': for invariant subspace only (SEP); * = 'B': for both eigenvalues and invariant subspace (S and * SEP). * * COMPQ (input) CHARACTER*1 * = 'V': update the matrix Q of Schur vectors; * = 'N': do not update Q. * * SELECT (input) LOGICAL array, dimension (N) * SELECT specifies the eigenvalues in the selected cluster. To * select the j-th eigenvalue, SELECT(j) must be set to .TRUE.. * * N (input) INTEGER * The order of the matrix T. N >= 0. * * T (input/output) COMPLEX*16 array, dimension (LDT,N) * On entry, the upper triangular matrix T. * On exit, T is overwritten by the reordered matrix T, with the * selected eigenvalues as the leading diagonal elements. * * LDT (input) INTEGER * The leading dimension of the array T. LDT >= max(1,N). * * Q (input/output) COMPLEX*16 array, dimension (LDQ,N) * On entry, if COMPQ = 'V', the matrix Q of Schur vectors. * On exit, if COMPQ = 'V', Q has been postmultiplied by the * unitary transformation matrix which reorders T; the leading M * columns of Q form an orthonormal basis for the specified * invariant subspace. * If COMPQ = 'N', Q is not referenced. * * LDQ (input) INTEGER * The leading dimension of the array Q. * LDQ >= 1; and if COMPQ = 'V', LDQ >= N. * * W (output) COMPLEX*16 * The reordered eigenvalues of T, in the same order as they * appear on the diagonal of T. * * M (output) INTEGER * The dimension of the specified invariant subspace. * 0 <= M <= N. * * S (output) DOUBLE PRECISION * If JOB = 'E' or 'B', S is a lower bound on the reciprocal * condition number for the selected cluster of eigenvalues. * S cannot underestimate the true reciprocal condition number * by more than a factor of sqrt(N). If M = 0 or N, S = 1. * If JOB = 'N' or 'V', S is not referenced. * * SEP (output) DOUBLE PRECISION * If JOB = 'V' or 'B', SEP is the estimated reciprocal * condition number of the specified invariant subspace. If * M = 0 or N, SEP = norm(T). * If JOB = 'N' or 'E', SEP is not referenced. * * WORK (workspace) COMPLEX*16 array, dimension (LWORK) * If JOB = 'N', WORK is not referenced. * * LWORK (input) INTEGER * The dimension of the array WORK. * If JOB = 'N', LWORK >= 1; * if JOB = 'E', LWORK = M*(N-M); * if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * Further Details * =============== * * ZTRSEN first collects the selected eigenvalues by computing a unitary * transformation Z to move them to the top left corner of T. In other * words, the selected eigenvalues are the eigenvalues of T11 in: * * Z'*T*Z = ( T11 T12 ) n1 * ( 0 T22 ) n2 * n1 n2 * * where N = n1+n2 and Z' means the conjugate transpose of Z. The first * n1 columns of Z span the specified invariant subspace of T. * * If T has been obtained from the Schur factorization of a matrix * A = Q*T*Q', then the reordered Schur factorization of A is given by * A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the * corresponding invariant subspace of A. * * The reciprocal condition number of the average of the eigenvalues of * T11 may be returned in S. S lies between 0 (very badly conditioned) * and 1 (very well conditioned). It is computed as follows. First we * compute R so that * * P = ( I R ) n1 * ( 0 0 ) n2 * n1 n2 * * is the projector on the invariant subspace associated with T11. * R is the solution of the Sylvester equation: * * T11*R - R*T22 = T12. * * Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote * the two-norm of M. Then S is computed as the lower bound * * (1 + F-norm(R)**2)**(-1/2) * * on the reciprocal of 2-norm(P), the true reciprocal condition number. * S cannot underestimate 1 / 2-norm(P) by more than a factor of * sqrt(N). * * An approximate error bound for the computed average of the * eigenvalues of T11 is * * EPS * norm(T) / S * * where EPS is the machine precision. * * The reciprocal condition number of the right invariant subspace * spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. * SEP is defined as the separation of T11 and T22: * * sep( T11, T22 ) = sigma-min( C ) * * where sigma-min(C) is the smallest singular value of the * n1*n2-by-n1*n2 matrix * * C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) * * I(m) is an m by m identity matrix, and kprod denotes the Kronecker * product. We estimate sigma-min(C) by the reciprocal of an estimate of * the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) * cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). * * When SEP is small, small changes in T can cause large changes in * the invariant subspace. An approximate bound on the maximum angular * error in the computed right invariant subspace is * * EPS * norm(T) / SEP * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL WANTBH, WANTQ, WANTS, WANTSP INTEGER IERR, K, KASE, KS, N1, N2, NN DOUBLE PRECISION EST, RNORM, SCALE * .. * .. Local Arrays .. DOUBLE PRECISION RWORK( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION ZLANGE EXTERNAL LSAME, ZLANGE * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLACON, ZLACPY, ZTREXC, ZTRSYL * .. * .. Intrinsic Functions .. INTRINSIC MAX, SQRT * .. * .. Executable Statements .. * * Decode and test the input parameters. * WANTBH = LSAME( JOB, 'B' ) WANTS = LSAME( JOB, 'E' ) .OR. WANTBH WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH WANTQ = LSAME( COMPQ, 'V' ) * * Set M to the number of selected eigenvalues. * M = 0 DO 10 K = 1, N IF( SELECT( K ) ) $ M = M + 1 10 CONTINUE * N1 = M N2 = N - M NN = N1*N2 * INFO = 0 IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP ) $ THEN INFO = -1 ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN INFO = -2 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( LDT.LT.MAX( 1, N ) ) THEN INFO = -6 ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN INFO = -8 ELSE IF( LWORK.LT.1 .OR. ( ( WANTS .AND. .NOT.WANTSP ) .AND. $ LWORK.LT.NN ) .OR. ( WANTSP .AND. LWORK.LT.2*NN ) ) THEN INFO = -14 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRSEN', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.N .OR. M.EQ.0 ) THEN IF( WANTS ) $ S = ONE IF( WANTSP ) $ SEP = ZLANGE( '1', N, N, T, LDT, RWORK ) GO TO 40 END IF * * Collect the selected eigenvalues at the top left corner of T. * KS = 0 DO 20 K = 1, N IF( SELECT( K ) ) THEN KS = KS + 1 * * Swap the K-th eigenvalue to position KS. * IF( K.NE.KS ) $ CALL ZTREXC( COMPQ, N, T, LDT, Q, LDQ, K, KS, IERR ) END IF 20 CONTINUE * IF( WANTS ) THEN * * Solve the Sylvester equation for R: * * T11*R - R*T22 = scale*T12 * CALL ZLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 ) CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ), $ LDT, WORK, N1, SCALE, IERR ) * * Estimate the reciprocal of the condition number of the cluster * of eigenvalues. * RNORM = ZLANGE( 'F', N1, N2, WORK, N1, RWORK ) IF( RNORM.EQ.ZERO ) THEN S = ONE ELSE S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )* $ SQRT( RNORM ) ) END IF END IF * IF( WANTSP ) THEN * * Estimate sep(T11,T22). * EST = ZERO KASE = 0 30 CONTINUE CALL ZLACON( NN, WORK( NN+1 ), WORK, EST, KASE ) IF( KASE.NE.0 ) THEN IF( KASE.EQ.1 ) THEN * * Solve T11*R - R*T22 = scale*X. * CALL ZTRSYL( 'N', 'N', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) ELSE * * Solve T11'*R - R*T22' = scale*X. * CALL ZTRSYL( 'C', 'C', -1, N1, N2, T, LDT, $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE, $ IERR ) END IF GO TO 30 END IF * SEP = SCALE / EST END IF * 40 CONTINUE * * Copy reordered eigenvalues to W. * DO 50 K = 1, N W( K ) = T( K, K ) 50 CONTINUE RETURN * * End of ZTRSEN * END arpack-akloeckner-07/LAPACK/ztrsyl.f0000644000175000017500000002661206153460202017151 0ustar andreasandreas SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * March 31, 1993 * * .. Scalar Arguments .. CHARACTER TRANA, TRANB INTEGER INFO, ISGN, LDA, LDB, LDC, M, N DOUBLE PRECISION SCALE * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZTRSYL solves the complex Sylvester matrix equation: * * op(A)*X + X*op(B) = scale*C or * op(A)*X - X*op(B) = scale*C, * * where op(A) = A or A**H, and A and B are both upper triangular. A is * M-by-M and B is N-by-N; the right hand side C and the solution X are * M-by-N; and scale is an output scale factor, set <= 1 to avoid * overflow in X. * * Arguments * ========= * * TRANA (input) CHARACTER*1 * Specifies the option op(A): * = 'N': op(A) = A (No transpose) * = 'C': op(A) = A**H (Conjugate transpose) * * TRANB (input) CHARACTER*1 * Specifies the option op(B): * = 'N': op(B) = B (No transpose) * = 'C': op(B) = B**H (Conjugate transpose) * * ISGN (input) INTEGER * Specifies the sign in the equation: * = +1: solve op(A)*X + X*op(B) = scale*C * = -1: solve op(A)*X - X*op(B) = scale*C * * M (input) INTEGER * The order of the matrix A, and the number of rows in the * matrices X and C. M >= 0. * * N (input) INTEGER * The order of the matrix B, and the number of columns in the * matrices X and C. N >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,M) * The upper triangular matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * * B (input) COMPLEX*16 array, dimension (LDB,N) * The upper triangular matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the M-by-N right hand side matrix C. * On exit, C is overwritten by the solution matrix X. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M) * * SCALE (output) DOUBLE PRECISION * The scale factor, scale, set <= 1 to avoid overflow in X. * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * = 1: A and B have common or very close eigenvalues; perturbed * values were used to solve the equation (but the matrices * A and B are unchanged). * * ===================================================================== * * .. Parameters .. DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) * .. * .. Local Scalars .. LOGICAL NOTRNA, NOTRNB INTEGER J, K, L DOUBLE PRECISION BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN, $ SMLNUM COMPLEX*16 A11, SUML, SUMR, VEC, X11 * .. * .. Local Arrays .. DOUBLE PRECISION DUM( 1 ) * .. * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DLAMCH, ZLANGE COMPLEX*16 ZDOTC, ZDOTU EXTERNAL LSAME, DLAMCH, ZLANGE, ZDOTC, ZDOTU * .. * .. External Subroutines .. EXTERNAL DLABAD, XERBLA, ZDSCAL * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, MIN * .. * .. Executable Statements .. * * Decode and Test input parameters * NOTRNA = LSAME( TRANA, 'N' ) NOTRNB = LSAME( TRANB, 'N' ) * INFO = 0 IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT. $ LSAME( TRANA, 'C' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT. $ LSAME( TRANB, 'C' ) ) THEN INFO = -2 ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN INFO = -3 ELSE IF( M.LT.0 ) THEN INFO = -4 ELSE IF( N.LT.0 ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -7 ELSE IF( LDB.LT.MAX( 1, N ) ) THEN INFO = -9 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -11 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZTRSYL', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 ) $ RETURN * * Set constants to control overflow * EPS = DLAMCH( 'P' ) SMLNUM = DLAMCH( 'S' ) BIGNUM = ONE / SMLNUM CALL DLABAD( SMLNUM, BIGNUM ) SMLNUM = SMLNUM*DBLE( M*N ) / EPS BIGNUM = ONE / SMLNUM SMIN = MAX( SMLNUM, EPS*ZLANGE( 'M', M, M, A, LDA, DUM ), $ EPS*ZLANGE( 'M', N, N, B, LDB, DUM ) ) SCALE = ONE SGN = ISGN * IF( NOTRNA .AND. NOTRNB ) THEN * * Solve A*X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * M L-1 * R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. * I=K+1 J=1 * DO 30 L = 1, N DO 20 K = M, 1, -1 * SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, $ C( MIN( K+1, M ), L ), 1 ) SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) VEC = C( K, L ) - ( SUML+SGN*SUMR ) * SCALOC = ONE A11 = A( K, K ) + SGN*B( L, L ) DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF X11 = ( VEC*DCMPLX( SCALOC ) ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 10 J = 1, N CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) 10 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 20 CONTINUE 30 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN * * Solve A' *X + ISGN*X*B = scale*C. * * The (K,L)th block of X is determined starting from * upper-left corner column by column by * * A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) * * Where * K-1 L-1 * R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] * I=1 J=1 * DO 60 L = 1, N DO 50 K = 1, M * SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) SUMR = ZDOTU( L-1, C( K, 1 ), LDC, B( 1, L ), 1 ) VEC = C( K, L ) - ( SUML+SGN*SUMR ) * SCALOC = ONE A11 = DCONJG( A( K, K ) ) + SGN*B( L, L ) DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ( VEC*DCMPLX( SCALOC ) ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 40 J = 1, N CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) 40 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 50 CONTINUE 60 CONTINUE * ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A'*X + ISGN*X*B' = C. * * The (K,L)th block of X is determined starting from * upper-right corner column by column by * * A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) * * Where * K-1 * R(K,L) = SUM [A'(I,K)*X(I,L)] + * I=1 * N * ISGN*SUM [X(K,J)*B'(L,J)]. * J=L+1 * DO 90 L = N, 1, -1 DO 80 K = 1, M * SUML = ZDOTC( K-1, A( 1, K ), 1, C( 1, L ), 1 ) SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, $ B( L, MIN( L+1, N ) ), LDB ) VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) ) * SCALOC = ONE A11 = DCONJG( A( K, K )+SGN*B( L, L ) ) DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ( VEC*DCMPLX( SCALOC ) ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 70 J = 1, N CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) 70 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 80 CONTINUE 90 CONTINUE * ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN * * Solve A*X + ISGN*X*B' = C. * * The (K,L)th block of X is determined starting from * bottom-left corner column by column by * * A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) * * Where * M N * R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] * I=K+1 J=L+1 * DO 120 L = N, 1, -1 DO 110 K = M, 1, -1 * SUML = ZDOTU( M-K, A( K, MIN( K+1, M ) ), LDA, $ C( MIN( K+1, M ), L ), 1 ) SUMR = ZDOTC( N-L, C( K, MIN( L+1, N ) ), LDC, $ B( L, MIN( L+1, N ) ), LDB ) VEC = C( K, L ) - ( SUML+SGN*DCONJG( SUMR ) ) * SCALOC = ONE A11 = A( K, K ) + SGN*DCONJG( B( L, L ) ) DA11 = ABS( DBLE( A11 ) ) + ABS( DIMAG( A11 ) ) IF( DA11.LE.SMIN ) THEN A11 = SMIN DA11 = SMIN INFO = 1 END IF DB = ABS( DBLE( VEC ) ) + ABS( DIMAG( VEC ) ) IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN IF( DB.GT.BIGNUM*DA11 ) $ SCALOC = ONE / DB END IF * X11 = ( VEC*DCMPLX( SCALOC ) ) / A11 * IF( SCALOC.NE.ONE ) THEN DO 100 J = 1, N CALL ZDSCAL( M, SCALOC, C( 1, J ), 1 ) 100 CONTINUE SCALE = SCALE*SCALOC END IF C( K, L ) = X11 * 110 CONTINUE 120 CONTINUE * END IF * RETURN * * End of ZTRSYL * END arpack-akloeckner-07/LAPACK/zunm2r.f0000644000175000017500000001247106153460203017036 0ustar andreasandreas SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * * -- LAPACK routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER INFO, K, LDA, LDC, M, N * .. * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) * .. * * Purpose * ======= * * ZUNM2R overwrites the general complex m-by-n matrix C with * * Q * C if SIDE = 'L' and TRANS = 'N', or * * Q'* C if SIDE = 'L' and TRANS = 'C', or * * C * Q if SIDE = 'R' and TRANS = 'N', or * * C * Q' if SIDE = 'R' and TRANS = 'C', * * where Q is a complex unitary matrix defined as the product of k * elementary reflectors * * Q = H(1) H(2) . . . H(k) * * as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n * if SIDE = 'R'. * * Arguments * ========= * * SIDE (input) CHARACTER*1 * = 'L': apply Q or Q' from the Left * = 'R': apply Q or Q' from the Right * * TRANS (input) CHARACTER*1 * = 'N': apply Q (No transpose) * = 'C': apply Q' (Conjugate transpose) * * M (input) INTEGER * The number of rows of the matrix C. M >= 0. * * N (input) INTEGER * The number of columns of the matrix C. N >= 0. * * K (input) INTEGER * The number of elementary reflectors whose product defines * the matrix Q. * If SIDE = 'L', M >= K >= 0; * if SIDE = 'R', N >= K >= 0. * * A (input) COMPLEX*16 array, dimension (LDA,K) * The i-th column must contain the vector which defines the * elementary reflector H(i), for i = 1,2,...,k, as returned by * ZGEQRF in the first k columns of its array argument A. * A is modified by the routine but restored on exit. * * LDA (input) INTEGER * The leading dimension of the array A. * If SIDE = 'L', LDA >= max(1,M); * if SIDE = 'R', LDA >= max(1,N). * * TAU (input) COMPLEX*16 array, dimension (K) * TAU(i) must contain the scalar factor of the elementary * reflector H(i), as returned by ZGEQRF. * * C (input/output) COMPLEX*16 array, dimension (LDC,N) * On entry, the m-by-n matrix C. * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. * * LDC (input) INTEGER * The leading dimension of the array C. LDC >= max(1,M). * * WORK (workspace) COMPLEX*16 array, dimension * (N) if SIDE = 'L', * (M) if SIDE = 'R' * * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value * * ===================================================================== * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) * .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ COMPLEX*16 AII, TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. EXTERNAL XERBLA, ZLARF * .. * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input arguments * INFO = 0 LEFT = LSAME( SIDE, 'L' ) NOTRAN = LSAME( TRANS, 'N' ) * * NQ is the order of Q * IF( LEFT ) THEN NQ = M ELSE NQ = N END IF IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN INFO = -1 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN INFO = -5 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN INFO = -7 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN INFO = -10 END IF IF( INFO.NE.0 ) THEN CALL XERBLA( 'ZUNM2R', -INFO ) RETURN END IF * * Quick return if possible * IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) $ RETURN * IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN I1 = 1 I2 = K I3 = 1 ELSE I1 = K I2 = 1 I3 = -1 END IF * IF( LEFT ) THEN NI = N JC = 1 ELSE MI = M IC = 1 END IF * DO 10 I = I1, I2, I3 IF( LEFT ) THEN * * H(i) or H(i)' is applied to C(i:m,1:n) * MI = M - I + 1 IC = I ELSE * * H(i) or H(i)' is applied to C(1:m,i:n) * NI = N - I + 1 JC = I END IF * * Apply H(i) or H(i)' * IF( NOTRAN ) THEN TAUI = TAU( I ) ELSE TAUI = DCONJG( TAU( I ) ) END IF AII = A( I, I ) A( I, I ) = ONE CALL ZLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, $ WORK ) A( I, I ) = AII 10 CONTINUE RETURN * * End of ZUNM2R * END arpack-akloeckner-07/LAPACK/Makefile0000644000175000017500000001043206221772057017076 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: Makefile # # Purpose: Sources Makefile # # Creation date: February 22, 1996 # # Modified:a September 9, 1996 # # Send bug reports, comments or suggestions to arpack.caam.rice.edu # ############################################################################ #\SCCS Information: @(#) # FILE: Makefile SID: 2.2 DATE OF SID: 9/24/96 RELEASE: 2 include ../ARmake.inc ############################################################################ # To create or add to the library, enter make followed by one or # more of the precisions desired. Targets sdrv, ddrv, cdrv, # zdrv are used to add to the library LAPACK routines needed by driver # programs in the EXAMPLES directory. # # Some examples: # make single # make single sdrv # make single complex # make single double complex complex16 # Alternatively, the command # make # without any arguments creates a library of all four precisions. # The library also contains all extra BLAS routines used by driver # programs in the EXAMPLES directory. # # The name of the library is defined by $(ARPACKLIB) in # ../ARmake.inc and is created at the next higher directory level. # # SOBJ = sgeqr2.o slabad.o slacon.o slacpy.o sladiv.o slae2.o slaev2.o\ slaexc.o slagtm.o slahqr.o slaln2.o slamch.o slange.o slanhs.o\ slanst.o slanv2.o slaptm.o slapy2.o slapy3.o slaran.o slarf.o\ slarfg.o slarfx.o slarnd.o slarnv.o slartg.o slaruv.o slascl.o\ slaset.o slasr.o slasrt.o slassq.o slasy2.o sorm2r.o ssteqr.o\ strevc.o strexc.o strsen.o strsyl.o DOBJ = dgeqr2.o dlabad.o dlacon.o dlacpy.o dladiv.o dlae2.o dlaev2.o\ dlaexc.o dlagtm.o dlahqr.o dlaln2.o dlamch.o dlange.o dlanhs.o\ dlanst.o dlanv2.o dlaptm.o dlapy2.o dlapy3.o dlaran.o dlarf.o\ dlarfg.o dlarfx.o dlarnd.o dlarnv.o dlartg.o dlaruv.o dlascl.o\ dlaset.o dlasr.o dlasrt.o dlassq.o dlasy2.o dorm2r.o dsteqr.o\ dtrevc.o dtrexc.o dtrsen.o dtrsyl.o IOBJ = ilaenv.o lsame.o lsamen.o xerbla.o xlaenv.o CIOBJ = icmax1.o ZIOBJ = izmax1.o COBJ = cgeqr2.o clacon.o clacpy.o cladiv.o clahqr.o clange.o clanhs.o\ clarf.o clarfg.o clarnv.o clartg.o clascl.o claset.o classq.o\ clatrs.o cmach.o crot.o ctrevc.o ctrexc.o ctrsen.o ctrsyl.o\ cunm2r.o\ scsum1.o slabad.o sladiv.o slamch.o slapy2.o slapy3.o slaruv.o ZOBJ = zgeqr2.o zlacon.o zlacpy.o zladiv.o zlahqr.o zlange.o zlanhs.o\ zlarf.o zlarfg.o zlarnv.o zlartg.o zlascl.o zlaset.o zlassq.o\ zlatrs.o zmach.o zrot.o ztrevc.o ztrexc.o ztrsen.o ztrsyl.o\ zunm2r.o\ dzsum1.o dlabad.o dladiv.o dlamch.o dlapy2.o dlapy3.o dlaruv.o # # The following LAPACK routines are not needed by ARPACK # source code. They are used by the drivers in EXAMPLES # directory. # SDRVOBJ = sgbtf2.o sgbtrf.o sgbtrs.o sgttrf.o sgttrs.o spttrf.o spttrs.o\ slaswp.o DDRVOBJ = dgbtf2.o dgbtrf.o dgbtrs.o dgttrf.o dgttrs.o dpttrf.o dpttrs.o\ dlaswp.o CDRVOBJ = cgbtf2.o cgbtrf.o cgbtrs.o cgttrf.o cgttrs.o claswp.o clacgv.o ZDRVOBJ = zgbtrf.o zgbtrs.o zgbtf2.o zgttrf.o zgttrs.o zlaswp.o zlacgv.o .SUFFIXES: .o .F .f .f.o: $(FC) $(FFLAGS) -c $< all: single double complex complex16 sdrv ddrv cdrv zdrv single: $(SOBJ) $(IOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ) $(IOBJ) $(RANLIB) $(ARPACKLIB) double: $(DOBJ) $(IOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ) $(IOBJ) $(RANLIB) $(ARPACKLIB) complex: $(COBJ) $(CIOBJ) $(IOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(COBJ) $(CIOBJ) $(IOBJ) $(RANLIB) $(ARPACKLIB) complex16: $(ZOBJ) $(ZIOBJ) $(IOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(ZOBJ) $(ZIOBJ) $(IOBJ) $(RANLIB) $(ARPACKLIB) # # Add routines needed by driver programs (in the EXAMPLES # directory) to $(ARPACKLIB). # sdrv: $(SDRVOBJ) $(CDRVOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(SDRVOBJ) $(CDRVOBJ) $(RANLIB) $(ARPACKLIB) ddrv: $(DDRVOBJ) $(ZDRVOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(DDRVOBJ) $(ZDRVOBJ) $(RANLIB) $(ARPACKLIB) cdrv: $(CDRVOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(CDRVOBJ) $(RANLIB) $(ARPACKLIB) zdrv: $(ZDRVOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(ZDRVOBJ) $(RANLIB) $(ARPACKLIB) # clean - remove all object files # clean: rm -f *.o a.out core arpack-akloeckner-07/UTIL/0000755000175000017500000000000010670624160015252 5ustar andreasandreasarpack-akloeckner-07/UTIL/dmout.f0000644000175000017500000001265706034032754016565 0ustar andreasandreas*----------------------------------------------------------------------- * Routine: DMOUT * * Purpose: Real matrix output routine. * * Usage: CALL DMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) * * Arguments * M - Number of rows of A. (Input) * N - Number of columns of A. (Input) * A - Real M by N matrix to be printed. (Input) * LDA - Leading dimension of A exactly as specified in the * dimension statement of the calling program. (Input) * IFMT - Format to be used in printing matrix A. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE DMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES * .. Scalar Arguments .. CHARACTER*( * ) IFMT INTEGER IDIGIT, LDA, LOUT, M, N * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ) * .. * .. Local Scalars .. CHARACTER*80 LINE INTEGER I, J, K1, K2, LLL, NDIGIT * .. * .. Local Arrays .. CHARACTER ICOL( 3 ) * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN, MIN0 * .. * .. Data statements .. DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', $ 'l' / * .. * .. Executable Statements .. * ... * ... FIRST EXECUTABLE STATEMENT * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A, / 1X, A ) * IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 40 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) DO 30 I = 1, M WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) 30 CONTINUE 40 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 60 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) DO 50 I = 1, M WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) 50 CONTINUE 60 CONTINUE * ELSE IF( NDIGIT.LE.10 ) THEN DO 80 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) DO 70 I = 1, M WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) 70 CONTINUE 80 CONTINUE * ELSE DO 100 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) DO 90 I = 1, M WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) 90 CONTINUE 100 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 120 K1 = 1, N, 10 K2 = MIN0( N, K1+9 ) WRITE( LOUT, FMT = 9998 )( ICOL, I, I = K1, K2 ) DO 110 I = 1, M WRITE( LOUT, FMT = 9994 )I, ( A( I, J ), J = K1, K2 ) 110 CONTINUE 120 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 140 K1 = 1, N, 8 K2 = MIN0( N, K1+7 ) WRITE( LOUT, FMT = 9997 )( ICOL, I, I = K1, K2 ) DO 130 I = 1, M WRITE( LOUT, FMT = 9993 )I, ( A( I, J ), J = K1, K2 ) 130 CONTINUE 140 CONTINUE * ELSE IF( NDIGIT.LE.10 ) THEN DO 160 K1 = 1, N, 6 K2 = MIN0( N, K1+5 ) WRITE( LOUT, FMT = 9996 )( ICOL, I, I = K1, K2 ) DO 150 I = 1, M WRITE( LOUT, FMT = 9992 )I, ( A( I, J ), J = K1, K2 ) 150 CONTINUE 160 CONTINUE * ELSE DO 180 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, FMT = 9995 )( ICOL, I, I = K1, K2 ) DO 170 I = 1, M WRITE( LOUT, FMT = 9991 )I, ( A( I, J ), J = K1, K2 ) 170 CONTINUE 180 CONTINUE END IF END IF WRITE( LOUT, FMT = 9990 ) * 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 10D12.3 ) 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 8D14.5 ) 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 6D18.9 ) 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P, 5D22.13 ) 9990 FORMAT( 1X, ' ' ) * RETURN END arpack-akloeckner-07/UTIL/dvout.f0000644000175000017500000000760406034032754016572 0ustar andreasandreas*----------------------------------------------------------------------- * Routine: DVOUT * * Purpose: Real vector output routine. * * Usage: CALL DVOUT (LOUT, N, SX, IDIGIT, IFMT) * * Arguments * N - Length of array SX. (Input) * SX - Real array to be printed. (Input) * IFMT - Format to be used in printing array SX. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE DVOUT( LOUT, N, SX, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES * .. Scalar Arguments .. CHARACTER*( * ) IFMT INTEGER IDIGIT, LOUT, N * .. * .. Array Arguments .. DOUBLE PRECISION SX( * ) * .. * .. Local Scalars .. CHARACTER*80 LINE INTEGER I, K1, K2, LLL, NDIGIT * .. * .. Intrinsic Functions .. INTRINSIC LEN, MIN, MIN0 * .. * .. Executable Statements .. * ... * ... FIRST EXECUTABLE STATEMENT * * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, FMT = 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A, / 1X, A ) * IF( N.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 30 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) 30 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 40 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) 40 CONTINUE ELSE IF( NDIGIT.LE.10 ) THEN DO 50 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) 50 CONTINUE ELSE DO 60 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) 60 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 70 K1 = 1, N, 10 K2 = MIN0( N, K1+9 ) WRITE( LOUT, FMT = 9998 )K1, K2, ( SX( I ), I = K1, K2 ) 70 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 80 K1 = 1, N, 8 K2 = MIN0( N, K1+7 ) WRITE( LOUT, FMT = 9997 )K1, K2, ( SX( I ), I = K1, K2 ) 80 CONTINUE ELSE IF( NDIGIT.LE.10 ) THEN DO 90 K1 = 1, N, 6 K2 = MIN0( N, K1+5 ) WRITE( LOUT, FMT = 9996 )K1, K2, ( SX( I ), I = K1, K2 ) 90 CONTINUE ELSE DO 100 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, FMT = 9995 )K1, K2, ( SX( I ), I = K1, K2 ) 100 CONTINUE END IF END IF WRITE( LOUT, FMT = 9994 ) RETURN 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P, 10D12.3 ) 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 8D14.5 ) 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 6D18.9 ) 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P, 5D24.13 ) 9994 FORMAT( 1X, ' ' ) END arpack-akloeckner-07/UTIL/icnteq.f0000644000175000017500000000060406034032754016705 0ustar andreasandreasc c----------------------------------------------------------------------- c c Count the number of elements equal to a specified integer value. c integer function icnteq (n, array, value) c integer n, value integer array(*) c k = 0 do 10 i = 1, n if (array(i) .eq. value) k = k + 1 10 continue icnteq = k c return end arpack-akloeckner-07/UTIL/icopy.f0000644000175000017500000000363506034032754016554 0ustar andreasandreas*-------------------------------------------------------------------- *\Documentation * *\Name: ICOPY * *\Description: * ICOPY copies an integer vector lx to an integer vector ly. * *\Usage: * call icopy ( n, lx, inc, ly, incy ) * *\Arguments: * n integer (input) * On entry, n is the number of elements of lx to be c copied to ly. * * lx integer array (input) * On entry, lx is the integer vector to be copied. * * incx integer (input) * On entry, incx is the increment between elements of lx. * * ly integer array (input) * On exit, ly is the integer vector that contains the * copy of lx. * * incy integer (input) * On entry, incy is the increment between elements of ly. * *\Enddoc * *-------------------------------------------------------------------- * subroutine icopy( n, lx, incx, ly, incy ) * * ---------------------------- * Specifications for arguments * ---------------------------- integer incx, incy, n integer lx( 1 ), ly( 1 ) * * ---------------------------------- * Specifications for local variables * ---------------------------------- integer i, ix, iy * * -------------------------- * First executable statement * -------------------------- 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 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 ly( iy ) = lx( ix ) ix = ix + incx iy = iy + incy 10 continue return c c.....code for both increments equal to 1 c 20 continue do 30 i = 1, n ly( i ) = lx( i ) 30 continue return end arpack-akloeckner-07/UTIL/iset.f0000644000175000017500000000050506034032754016366 0ustar andreasandreasc c----------------------------------------------------------------------- c c Only work with increment equal to 1 right now. c subroutine iset (n, value, array, inc) c integer n, value, inc integer array(*) c do 10 i = 1, n array(i) = value 10 continue c return end arpack-akloeckner-07/UTIL/iswap.f0000644000175000017500000000231306034032754016544 0ustar andreasandreas subroutine iswap (n,sx,incx,sy,incy) c c interchanges two vectors. c uses unrolled loops for increments equal to 1. c jack dongarra, linpack, 3/11/78. c integer sx(1),sy(1),stemp integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments not equal c to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n stemp = sx(ix) sx(ix) = sy(iy) sy(iy) = stemp ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,3) if( m .eq. 0 ) go to 40 do 30 i = 1,m stemp = sx(i) sx(i) = sy(i) sy(i) = stemp 30 continue if( n .lt. 3 ) return 40 mp1 = m + 1 do 50 i = mp1,n,3 stemp = sx(i) sx(i) = sy(i) sy(i) = stemp stemp = sx(i + 1) sx(i + 1) = sy(i + 1) sy(i + 1) = stemp stemp = sx(i + 2) sx(i + 2) = sy(i + 2) sy(i + 2) = stemp 50 continue return end arpack-akloeckner-07/UTIL/ivout.f0000644000175000017500000000645706034032754016604 0ustar andreasandreasC----------------------------------------------------------------------- C Routine: IVOUT C C Purpose: Integer vector output routine. C C Usage: CALL IVOUT (LOUT, N, IX, IDIGIT, IFMT) C C Arguments C N - Length of array IX. (Input) C IX - Integer array to be printed. (Input) C IFMT - Format to be used in printing array IX. (Input) C IDIGIT - Print up to ABS(IDIGIT) decimal digits / number. (Input) C If IDIGIT .LT. 0, printing is done with 72 columns. C If IDIGIT .GT. 0, printing is done with 132 columns. C C----------------------------------------------------------------------- C SUBROUTINE IVOUT (LOUT, N, IX, IDIGIT, IFMT) C ... C ... SPECIFICATIONS FOR ARGUMENTS INTEGER IX(*), N, IDIGIT, LOUT CHARACTER IFMT*(*) C ... C ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, NDIGIT, K1, K2, LLL CHARACTER*80 LINE * ... * ... SPECIFICATIONS INTRINSICS INTRINSIC MIN * C LLL = MIN ( LEN ( IFMT ), 80 ) DO 1 I = 1, LLL LINE(I:I) = '-' 1 CONTINUE C DO 2 I = LLL+1, 80 LINE(I:I) = ' ' 2 CONTINUE C WRITE ( LOUT, 2000 ) IFMT, LINE(1:LLL) 2000 FORMAT ( /1X, A /1X, A ) C IF (N .LE. 0) RETURN NDIGIT = IDIGIT IF (IDIGIT .EQ. 0) NDIGIT = 4 C C======================================================================= C CODE FOR OUTPUT USING 72 COLUMNS FORMAT C======================================================================= C IF (IDIGIT .LT. 0) THEN C NDIGIT = -IDIGIT IF (NDIGIT .LE. 4) THEN DO 10 K1 = 1, N, 10 K2 = MIN0(N,K1+9) WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) 10 CONTINUE C ELSE IF (NDIGIT .LE. 6) THEN DO 30 K1 = 1, N, 7 K2 = MIN0(N,K1+6) WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) 30 CONTINUE C ELSE IF (NDIGIT .LE. 10) THEN DO 50 K1 = 1, N, 5 K2 = MIN0(N,K1+4) WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) 50 CONTINUE C ELSE DO 70 K1 = 1, N, 3 K2 = MIN0(N,K1+2) WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) 70 CONTINUE END IF C C======================================================================= C CODE FOR OUTPUT USING 132 COLUMNS FORMAT C======================================================================= C ELSE C IF (NDIGIT .LE. 4) THEN DO 90 K1 = 1, N, 20 K2 = MIN0(N,K1+19) WRITE(LOUT,1000) K1,K2,(IX(I),I=K1,K2) 90 CONTINUE C ELSE IF (NDIGIT .LE. 6) THEN DO 110 K1 = 1, N, 15 K2 = MIN0(N,K1+14) WRITE(LOUT,1001) K1,K2,(IX(I),I=K1,K2) 110 CONTINUE C ELSE IF (NDIGIT .LE. 10) THEN DO 130 K1 = 1, N, 10 K2 = MIN0(N,K1+9) WRITE(LOUT,1002) K1,K2,(IX(I),I=K1,K2) 130 CONTINUE C ELSE DO 150 K1 = 1, N, 7 K2 = MIN0(N,K1+6) WRITE(LOUT,1003) K1,K2,(IX(I),I=K1,K2) 150 CONTINUE END IF END IF WRITE (LOUT,1004) C 1000 FORMAT(1X,I4,' - ',I4,':',20(1X,I5)) 1001 FORMAT(1X,I4,' - ',I4,':',15(1X,I7)) 1002 FORMAT(1X,I4,' - ',I4,':',10(1X,I11)) 1003 FORMAT(1X,I4,' - ',I4,':',7(1X,I15)) 1004 FORMAT(1X,' ') C RETURN END arpack-akloeckner-07/UTIL/smout.f0000644000175000017500000001214506034032754016574 0ustar andreasandreas*----------------------------------------------------------------------- * Routine: SMOUT * * Purpose: Real matrix output routine. * * Usage: CALL SMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) * * Arguments * M - Number of rows of A. (Input) * N - Number of columns of A. (Input) * A - Real M by N matrix to be printed. (Input) * LDA - Leading dimension of A exactly as specified in the * dimension statement of the calling program. (Input) * IFMT - Format to be used in printing matrix A. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE SMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER M, N, IDIGIT, LDA, LOUT REAL A( LDA, * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, J, NDIGIT, K1, K2, LLL CHARACTER*1 ICOL( 3 ) CHARACTER*80 LINE * ... * ... SPECIFICATIONS INTRINSICS INTRINSIC MIN * DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', $ 'l' / * ... * ... FIRST EXECUTABLE STATEMENT * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 40 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 30 I = 1, M WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) 30 CONTINUE 40 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 60 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 50 I = 1, M WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) 50 CONTINUE 60 CONTINUE * ELSE IF( NDIGIT.LE.10 ) THEN DO 80 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 70 I = 1, M WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) 70 CONTINUE 80 CONTINUE * ELSE DO 100 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) DO 90 I = 1, M WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 ) 90 CONTINUE 100 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 120 K1 = 1, N, 10 K2 = MIN0( N, K1+9 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 110 I = 1, M WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) 110 CONTINUE 120 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 140 K1 = 1, N, 8 K2 = MIN0( N, K1+7 ) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 130 I = 1, M WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) 130 CONTINUE 140 CONTINUE * ELSE IF( NDIGIT.LE.10 ) THEN DO 160 K1 = 1, N, 6 K2 = MIN0( N, K1+5 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 150 I = 1, M WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) 150 CONTINUE 160 CONTINUE * ELSE DO 180 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) DO 170 I = 1, M WRITE( LOUT, 9991 )I, ( A( I, J ), J = K1, K2 ) 170 CONTINUE 180 CONTINUE END IF END IF WRITE( LOUT, 9990 ) * 9998 FORMAT( 10X, 10( 4X, 3A1, I4, 1X ) ) 9997 FORMAT( 10X, 8( 5X, 3A1, I4, 2X ) ) 9996 FORMAT( 10X, 6( 7X, 3A1, I4, 4X ) ) 9995 FORMAT( 10X, 5( 9X, 3A1, I4, 6X ) ) 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P10E12.3 ) 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P8E14.5 ) 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P6E18.9 ) 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P5E22.13 ) 9990 FORMAT( 1X, ' ' ) * RETURN END arpack-akloeckner-07/UTIL/svout.f0000644000175000017500000000714406034032755016611 0ustar andreasandreas*----------------------------------------------------------------------- * Routine: SVOUT * * Purpose: Real vector output routine. * * Usage: CALL SVOUT (LOUT, N, SX, IDIGIT, IFMT) * * Arguments * N - Length of array SX. (Input) * SX - Real array to be printed. (Input) * IFMT - Format to be used in printing array SX. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE SVOUT( LOUT, N, SX, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER N, IDIGIT, LOUT REAL SX( * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, NDIGIT, K1, K2, LLL CHARACTER*80 LINE * ... * ... FIRST EXECUTABLE STATEMENT * * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( N.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 30 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 ) 30 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 40 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 ) 40 CONTINUE ELSE IF( NDIGIT.LE.10 ) THEN DO 50 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 ) 50 CONTINUE ELSE DO 60 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 ) 60 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 70 K1 = 1, N, 10 K2 = MIN0( N, K1+9 ) WRITE( LOUT, 9998 )K1, K2, ( SX( I ), I = K1, K2 ) 70 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 80 K1 = 1, N, 8 K2 = MIN0( N, K1+7 ) WRITE( LOUT, 9997 )K1, K2, ( SX( I ), I = K1, K2 ) 80 CONTINUE ELSE IF( NDIGIT.LE.10 ) THEN DO 90 K1 = 1, N, 6 K2 = MIN0( N, K1+5 ) WRITE( LOUT, 9996 )K1, K2, ( SX( I ), I = K1, K2 ) 90 CONTINUE ELSE DO 100 K1 = 1, N, 5 K2 = MIN0( N, K1+4 ) WRITE( LOUT, 9995 )K1, K2, ( SX( I ), I = K1, K2 ) 100 CONTINUE END IF END IF WRITE( LOUT, 9994 ) RETURN 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1P10E12.3 ) 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P8E14.5 ) 9996 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P6E18.9 ) 9995 FORMAT( 1X, I4, ' - ', I4, ':', 1X, 1P5E24.13 ) 9994 FORMAT( 1X, ' ' ) END arpack-akloeckner-07/UTIL/cmout.f0000644000175000017500000002106306052774162016561 0ustar andreasandreas* * Routine: CMOUT * * Purpose: Complex matrix output routine. * * Usage: CALL CMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) * * Arguments * M - Number of rows of A. (Input) * N - Number of columns of A. (Input) * A - Complex M by N matrix to be printed. (Input) * LDA - Leading dimension of A exactly as specified in the * dimension statement of the calling program. (Input) * IFMT - Format to be used in printing matrix A. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *\SCCS Information: @(#) * FILE: cmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 * *----------------------------------------------------------------------- * SUBROUTINE CMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER M, N, IDIGIT, LDA, LOUT Complex & A( LDA, * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, J, NDIGIT, K1, K2, LLL CHARACTER*1 ICOL( 3 ) CHARACTER*80 LINE * ... * ... SPECIFICATIONS INTRINSICS INTRINSIC MIN * DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', $ 'l' / * ... * ... FIRST EXECUTABLE STATEMENT * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 40 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 30 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 ) END IF 30 CONTINUE 40 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 60 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 50 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 ) END IF 50 CONTINUE 60 CONTINUE * ELSE IF( NDIGIT.LE.8 ) THEN DO 80 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 70 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 ) END IF 70 CONTINUE 80 CONTINUE * ELSE DO 100 K1 = 1, N WRITE( LOUT, 9995 ) ICOL, K1 DO 90 I = 1, M WRITE( LOUT, 9991 )I, A( I, K1 ) 90 CONTINUE 100 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 120 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 110 I = 1, M IF ((K1+3).LE.N) THEN WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+3-N).EQ.1) THEN WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 ) ELSE IF ((K1+3-N).EQ.2) THEN WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+3-N).EQ.3) THEN WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 ) END IF 110 CONTINUE 120 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 140 K1 = 1, N, 3 K2 = MIN0( N, K1+ 2) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 130 I = 1, M IF ((K1+2).LE.N) THEN WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.1) THEN WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.2) THEN WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 ) END IF 130 CONTINUE 140 CONTINUE * ELSE IF( NDIGIT.LE.8 ) THEN DO 160 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 150 I = 1, M IF ((K1+2).LE.N) THEN WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.1) THEN WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.2) THEN WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 ) END IF 150 CONTINUE 160 CONTINUE * ELSE DO 180 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) DO 170 I = 1, M IF ((K1+1).LE.N) THEN WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 ) END IF 170 CONTINUE 180 CONTINUE END IF END IF WRITE( LOUT, 9990 ) * 9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) ) 9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) ) 9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) ) 9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) ) * *======================================================== * FORMAT FOR 72 COLUMN *======================================================== * * DISPLAY 4 SIGNIFICANT DIGITS * 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') ) 9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') ) 9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') ) 9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13,')') ) 9990 FORMAT( 1X, ' ' ) * * *======================================================== * FORMAT FOR 132 COLUMN *======================================================== * * DISPLAY 4 SIGNIFICANT DIGIT * 9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',E10.3,',',E10.3,') ') ) 9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E10.3,',',E10.3,') ') ) 9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E10.3,',',E10.3,') ') ) 9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E10.3,',',E10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGIT * 9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E12.5,',',E12.5,') ') ) 9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E12.5,',',E12.5,') ') ) 9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E12.5,',',E12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGIT * 9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',E14.7,',',E14.7,') ') ) 9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E14.7,',',E14.7,') ') ) 9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E14.7,',',E14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGIT * 9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',E20.13,',',E20.13, & ') ')) 9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',E20.13,',',E20.13, & ') ')) * * * * RETURN END arpack-akloeckner-07/UTIL/cvout.f0000644000175000017500000002001506052774162016566 0ustar andreasandreasc----------------------------------------------------------------------- c c\SCCS Information: @(#) c FILE: cvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 c *----------------------------------------------------------------------- * Routine: CVOUT * * Purpose: Complex vector output routine. * * Usage: CALL CVOUT (LOUT, N, CX, IDIGIT, IFMT) * * Arguments * N - Length of array CX. (Input) * CX - Complex array to be printed. (Input) * IFMT - Format to be used in printing array CX. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE CVOUT( LOUT, N, CX, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER N, IDIGIT, LOUT Complex & CX( * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, NDIGIT, K1, K2, LLL CHARACTER*80 LINE * ... * ... FIRST EXECUTABLE STATEMENT * * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( N.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 30 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9998 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9997 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 30 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 40 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9988 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9987 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 40 CONTINUE ELSE IF( NDIGIT.LE.8 ) THEN DO 50 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9978 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9977 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 50 CONTINUE ELSE DO 60 K1 = 1, N WRITE( LOUT, 9968 )K1, K1, CX( I ) 60 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 70 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) IF ((K1+3).LE.N) THEN WRITE( LOUT, 9958 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 1) THEN WRITE( LOUT, 9957 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 2) THEN WRITE( LOUT, 9956 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 1) THEN WRITE( LOUT, 9955 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 70 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 80 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9948 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9947 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 2) THEN WRITE( LOUT, 9946 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 80 CONTINUE ELSE IF( NDIGIT.LE.8 ) THEN DO 90 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9938 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9937 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 2) THEN WRITE( LOUT, 9936 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 90 CONTINUE ELSE DO 100 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9928 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9927 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 100 CONTINUE END IF END IF WRITE( LOUT, 9994 ) RETURN * *======================================================================= * FORMAT FOR 72 COLUMNS *======================================================================= * * DISPLAY 4 SIGNIFICANT DIGITS * 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E10.3,',',E10.3,') ') ) 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E10.3,',',E10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E12.5,',',E12.5,') ') ) 9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E12.5,',',E12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E14.7,',',E14.7,') ') ) 9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E14.7,',',E14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E20.13,',',E20.13,') ') ) * *========================================================================= * FORMAT FOR 132 COLUMNS *========================================================================= * * DISPLAY 4 SIGNIFICANT DIGITS * 9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,4('(',E10.3,',',E10.3,') ') ) 9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',E10.3,',',E10.3,') ') ) 9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E10.3,',',E10.3,') ') ) 9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E10.3,',',E10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',E12.5,',',E12.5,') ') ) 9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E12.5,',',E12.5,') ') ) 9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E12.5,',',E12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',E14.7,',',E14.7,') ') ) 9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E14.7,',',E14.7,') ') ) 9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E14.7,',',E14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',E20.13,',',E20.13,') ') ) 9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',E20.13,',',E20.13,') ') ) * * * 9994 FORMAT( 1X, ' ' ) END arpack-akloeckner-07/UTIL/zmout.f0000644000175000017500000002107406052774172016613 0ustar andreasandreas* * Routine: ZMOUT * * Purpose: Complex*16 matrix output routine. * * Usage: CALL ZMOUT (LOUT, M, N, A, LDA, IDIGIT, IFMT) * * Arguments * M - Number of rows of A. (Input) * N - Number of columns of A. (Input) * A - Complex*16 M by N matrix to be printed. (Input) * LDA - Leading dimension of A exactly as specified in the * dimension statement of the calling program. (Input) * IFMT - Format to be used in printing matrix A. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *\SCCS Information: @(#) * FILE: zmout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 * *----------------------------------------------------------------------- * SUBROUTINE ZMOUT( LOUT, M, N, A, LDA, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER M, N, IDIGIT, LDA, LOUT Complex*16 & A( LDA, * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, J, NDIGIT, K1, K2, LLL CHARACTER*1 ICOL( 3 ) CHARACTER*80 LINE * ... * ... SPECIFICATIONS INTRINSICS INTRINSIC MIN * DATA ICOL( 1 ), ICOL( 2 ), ICOL( 3 ) / 'C', 'o', $ 'l' / * ... * ... FIRST EXECUTABLE STATEMENT * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( M.LE.0 .OR. N.LE.0 .OR. LDA.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 40 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 30 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9994 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9984 )I, ( A( I, J ), J = K1, K2 ) END IF 30 CONTINUE 40 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 60 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 50 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9993 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9983 )I, ( A( I, J ), J = K1, K2 ) END IF 50 CONTINUE 60 CONTINUE * ELSE IF( NDIGIT.LE.8 ) THEN DO 80 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 70 I = 1, M IF (K1.NE.N) THEN WRITE( LOUT, 9992 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9982 )I, ( A( I, J ), J = K1, K2 ) END IF 70 CONTINUE 80 CONTINUE * ELSE DO 100 K1 = 1, N WRITE( LOUT, 9995 ) ICOL, K1 DO 90 I = 1, M WRITE( LOUT, 9991 )I, A( I, K1 ) 90 CONTINUE 100 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 120 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) WRITE( LOUT, 9998 )( ICOL, I, I = K1, K2 ) DO 110 I = 1, M IF ((K1+3).LE.N) THEN WRITE( LOUT, 9974 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+3-N).EQ.1) THEN WRITE( LOUT, 9964 )I, ( A( I, J ), J = k1, K2 ) ELSE IF ((K1+3-N).EQ.2) THEN WRITE( LOUT, 9954 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+3-N).EQ.3) THEN WRITE( LOUT, 9944 )I, ( A( I, J ), J = K1, K2 ) END IF 110 CONTINUE 120 CONTINUE * ELSE IF( NDIGIT.LE.6 ) THEN DO 140 K1 = 1, N, 3 K2 = MIN0( N, K1+ 2) WRITE( LOUT, 9997 )( ICOL, I, I = K1, K2 ) DO 130 I = 1, M IF ((K1+2).LE.N) THEN WRITE( LOUT, 9973 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.1) THEN WRITE( LOUT, 9963 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.2) THEN WRITE( LOUT, 9953 )I, ( A( I, J ), J = K1, K2 ) END IF 130 CONTINUE 140 CONTINUE * ELSE IF( NDIGIT.LE.8 ) THEN DO 160 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) WRITE( LOUT, 9996 )( ICOL, I, I = K1, K2 ) DO 150 I = 1, M IF ((K1+2).LE.N) THEN WRITE( LOUT, 9972 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.1) THEN WRITE( LOUT, 9962 )I, ( A( I, J ), J = K1, K2 ) ELSE IF ((K1+2-N).EQ.2) THEN WRITE( LOUT, 9952 )I, ( A( I, J ), J = K1, K2 ) END IF 150 CONTINUE 160 CONTINUE * ELSE DO 180 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) WRITE( LOUT, 9995 )( ICOL, I, I = K1, K2 ) DO 170 I = 1, M IF ((K1+1).LE.N) THEN WRITE( LOUT, 9971 )I, ( A( I, J ), J = K1, K2 ) ELSE WRITE( LOUT, 9961 )I, ( A( I, J ), J = K1, K2 ) END IF 170 CONTINUE 180 CONTINUE END IF END IF WRITE( LOUT, 9990 ) * 9998 FORMAT( 11X, 4( 9X, 3A1, I4, 9X ) ) 9997 FORMAT( 10X, 4( 11X, 3A1, I4, 11X ) ) 9996 FORMAT( 10X, 3( 13X, 3A1, I4, 13X ) ) 9995 FORMAT( 12X, 2( 18x, 3A1, I4, 18X ) ) * *======================================================== * FORMAT FOR 72 COLUMN *======================================================== * * DISPLAY 4 SIGNIFICANT DIGITS * 9994 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') ) 9984 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9993 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') ) 9983 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9992 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') ) 9982 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9991 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13,')') ) 9990 FORMAT( 1X, ' ' ) * * *======================================================== * FORMAT FOR 132 COLUMN *======================================================== * * DISPLAY 4 SIGNIFICANT DIGIT * 9974 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,4('(',D10.3,',',D10.3,') ') ) 9964 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D10.3,',',D10.3,') ') ) 9954 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D10.3,',',D10.3,') ') ) 9944 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D10.3,',',D10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGIT * 9973 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D12.5,',',D12.5,') ') ) 9963 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D12.5,',',D12.5,') ') ) 9953 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D12.5,',',D12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGIT * 9972 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,3('(',D14.7,',',D14.7,') ') ) 9962 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D14.7,',',D14.7,') ') ) 9952 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D14.7,',',D14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGIT * 9971 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,2('(',D20.13,',',D20.13, & ') ')) 9961 FORMAT( 1X, ' Row', I4, ':', 1X, 1P,1('(',D20.13,',',D20.13, & ') ')) * * * * RETURN END arpack-akloeckner-07/UTIL/zvout.f0000644000175000017500000002002606052774172016620 0ustar andreasandreasc----------------------------------------------------------------------- c c\SCCS Information: @(#) c FILE: zvout.f SID: 2.1 DATE OF SID: 11/16/95 RELEASE: 2 c *----------------------------------------------------------------------- * Routine: ZVOUT * * Purpose: Complex*16 vector output routine. * * Usage: CALL ZVOUT (LOUT, N, CX, IDIGIT, IFMT) * * Arguments * N - Length of array CX. (Input) * CX - Complex*16 array to be printed. (Input) * IFMT - Format to be used in printing array CX. (Input) * IDIGIT - Print up to IABS(IDIGIT) decimal digits per number. (In) * If IDIGIT .LT. 0, printing is done with 72 columns. * If IDIGIT .GT. 0, printing is done with 132 columns. * *----------------------------------------------------------------------- * SUBROUTINE ZVOUT( LOUT, N, CX, IDIGIT, IFMT ) * ... * ... SPECIFICATIONS FOR ARGUMENTS INTEGER N, IDIGIT, LOUT Complex*16 & CX( * ) CHARACTER IFMT*( * ) * ... * ... SPECIFICATIONS FOR LOCAL VARIABLES INTEGER I, NDIGIT, K1, K2, LLL CHARACTER*80 LINE * ... * ... FIRST EXECUTABLE STATEMENT * * LLL = MIN( LEN( IFMT ), 80 ) DO 10 I = 1, LLL LINE( I: I ) = '-' 10 CONTINUE * DO 20 I = LLL + 1, 80 LINE( I: I ) = ' ' 20 CONTINUE * WRITE( LOUT, 9999 )IFMT, LINE( 1: LLL ) 9999 FORMAT( / 1X, A / 1X, A ) * IF( N.LE.0 ) $ RETURN NDIGIT = IDIGIT IF( IDIGIT.EQ.0 ) $ NDIGIT = 4 * *======================================================================= * CODE FOR OUTPUT USING 72 COLUMNS FORMAT *======================================================================= * IF( IDIGIT.LT.0 ) THEN NDIGIT = -IDIGIT IF( NDIGIT.LE.4 ) THEN DO 30 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9998 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9997 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 30 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 40 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9988 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9987 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 40 CONTINUE ELSE IF( NDIGIT.LE.8 ) THEN DO 50 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF (K1.NE.N) THEN WRITE( LOUT, 9978 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE WRITE( LOUT, 9977 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 50 CONTINUE ELSE DO 60 K1 = 1, N WRITE( LOUT, 9968 )K1, K1, CX( I ) 60 CONTINUE END IF * *======================================================================= * CODE FOR OUTPUT USING 132 COLUMNS FORMAT *======================================================================= * ELSE IF( NDIGIT.LE.4 ) THEN DO 70 K1 = 1, N, 4 K2 = MIN0( N, K1+3 ) IF ((K1+3).LE.N) THEN WRITE( LOUT, 9958 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 1) THEN WRITE( LOUT, 9957 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 2) THEN WRITE( LOUT, 9956 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+3-N) .EQ. 1) THEN WRITE( LOUT, 9955 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 70 CONTINUE ELSE IF( NDIGIT.LE.6 ) THEN DO 80 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9948 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9947 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 2) THEN WRITE( LOUT, 9946 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 80 CONTINUE ELSE IF( NDIGIT.LE.8 ) THEN DO 90 K1 = 1, N, 3 K2 = MIN0( N, K1+2 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9938 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9937 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 2) THEN WRITE( LOUT, 9936 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 90 CONTINUE ELSE DO 100 K1 = 1, N, 2 K2 = MIN0( N, K1+1 ) IF ((K1+2).LE.N) THEN WRITE( LOUT, 9928 )K1, K2, ( CX( I ), $ I = K1, K2 ) ELSE IF ((K1+2-N) .EQ. 1) THEN WRITE( LOUT, 9927 )K1, K2, ( CX( I ), $ I = K1, K2 ) END IF 100 CONTINUE END IF END IF WRITE( LOUT, 9994 ) RETURN * *======================================================================= * FORMAT FOR 72 COLUMNS *======================================================================= * * DISPLAY 4 SIGNIFICANT DIGITS * 9998 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D10.3,',',D10.3,') ') ) 9997 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D10.3,',',D10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9988 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D12.5,',',D12.5,') ') ) 9987 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D12.5,',',D12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9978 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D14.7,',',D14.7,') ') ) 9977 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D14.7,',',D14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9968 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D20.13,',',D20.13,') ') ) * *========================================================================= * FORMAT FOR 132 COLUMNS *========================================================================= * * DISPLAY 4 SIGNIFICANT DIGITS * 9958 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,4('(',D10.3,',',D10.3,') ') ) 9957 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',D10.3,',',D10.3,') ') ) 9956 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D10.3,',',D10.3,') ') ) 9955 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D10.3,',',D10.3,') ') ) * * DISPLAY 6 SIGNIFICANT DIGITS * 9948 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',D12.5,',',D12.5,') ') ) 9947 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D12.5,',',D12.5,') ') ) 9946 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D12.5,',',D12.5,') ') ) * * DISPLAY 8 SIGNIFICANT DIGITS * 9938 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,3('(',D14.7,',',D14.7,') ') ) 9937 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D14.7,',',D14.7,') ') ) 9936 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D14.7,',',D14.7,') ') ) * * DISPLAY 13 SIGNIFICANT DIGITS * 9928 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,2('(',D20.13,',',D20.13,') ') ) 9927 FORMAT( 1X, I4, ' - ', I4, ':', 1X, $ 1P,1('(',D20.13,',',D20.13,') ') ) * * * 9994 FORMAT( 1X, ' ' ) END arpack-akloeckner-07/UTIL/Makefile0000644000175000017500000000355510670622032016716 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: Makefile # # Purpose: Sources Makefile # # Creation date: February 22, 1996 # # Modified: September 6, 1996 # # Send bug reports, comments or suggestions to arpack.caam.rice.edu # ############################################################################ #\SCCS Information: @(#) # FILE: Makefile SID: 2.1 DATE OF SID: 9/9/96 RELEASE: 2 include ../ARmake.inc ############################################################################ # To create or add to the library, enter make followed by one or # more of the precisions desired. Some examples: # make single # make single complex # make single double complex complex16 # Alternatively, the command # make # without any arguments creates a library of all four precisions. # The name of the library is defined by $(ARPACKLIB) in # ../ARmake.inc and is created at the next higher directory level. # OBJS = icnteq.o icopy.o iset.o iswap.o ivout.o arscnd.o SOBJ = svout.o smout.o DOBJ = dvout.o dmout.o COBJ = cvout.o cmout.o ZOBJ = zvout.o zmout.o .SUFFIXES: .o .F .f .f.o: $(FC) $(FFLAGS) -c $< # # make the library containing both single and double precision # all: single double complex complex16 single: $(SOBJ) $(OBJS) $(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ) $(OBJS) $(RANLIB) $(ARPACKLIB) double: $(DOBJ) $(OBJS) $(ZOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ) $(OBJS) $(RANLIB) $(ARPACKLIB) complex: $(SOBJ) $(OBJS) $(COBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ) $(COBJ) $(OBJS) $(RANLIB) $(ARPACKLIB) complex16: $(DOBJ) $(OBJS) $(ZOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ) $(ZOBJ) $(OBJS) $(RANLIB) $(ARPACKLIB) # sdrv: ddrv: cdrv: zdrv: # # clean - remove all object files # clean: rm -f *.o a.out core arpack-akloeckner-07/UTIL/arscnd.f0000644000175000017500000000141410670622032016667 0ustar andreasandreas SUBROUTINE ARSCND( T ) * REAL T * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * July 26, 1991 * * Purpose * ======= * * ARSCND returns the user time for a process in seconds. * This version gets the time from the system function ETIME. * * .. Local Scalars .. REAL T1 * .. * .. Local Arrays .. REAL TARRAY( 2 ) * .. * .. External Functions .. REAL ETIME EXTERNAL ETIME * .. * .. Executable Statements .. * T1 = ETIME( TARRAY ) T = TARRAY( 1 ) RETURN * * End of ARSCND * END arpack-akloeckner-07/UTIL/libarpack_LINUX.a0000644000175000017500000025456210670623376020351 0ustar andreasandreas! / 1189291775 0 0 0 430 ` òò²²9ê=@¨C®GþGþ]Ž]Žaªaªwjwj™¢™¢ÃÂÃÂùJùJ#Ê#Êsvout___i686.get_pc_thunk.bxsmout___i686.get_pc_thunk.bxicnteq_icopy_iset_iswap_ivout___i686.get_pc_thunk.bxarscnd___i686.get_pc_thunk.bxdvout___i686.get_pc_thunk.bxdmout___i686.get_pc_thunk.bxcvout___i686.get_pc_thunk.bxcmout___i686.get_pc_thunk.bxzvout___i686.get_pc_thunk.bxzmout___i686.get_pc_thunk.bxsvout.o/ 1189291773 1000 1000 100644 5508 ` ELFÜ 4( U‰åWVSì‹U‹uèüÿÿÿËM ‹EƒúP‰uŒ‰Mˆ‰…|ÿÿÿ‰U„‰U€~ÇE€P‹u€E˜‰…XÿÿÿNx8»‰½lÿÿÿ‰Çf‰<$‹•lÿÿÿ¹‰L$ ¸G‰D$‰T$èüÿÿÿNyØ‹E€@‰Æ÷Ö‰÷ƒÇQxA‹•Xÿÿÿ‹‰hÿÿÿtÿv‰4$‹…hÿÿÿ¹‰L$ ºF‰T$‰D$èüÿÿÿOyØ‹UŒƒ‹ ‰‹‰$èüÿÿÿ‹u„‹‹}‰dÿÿÿ‰ $‰t$‰|$èüÿÿÿ‹U€‹…Xÿÿÿ‹µdÿÿÿ‰T$‰D$‰4$èüÿÿÿèüÿÿÿ‹}ˆ‹…ÉŽV‹}‹…À‰Âu¸…ÒˆTƒø@ÇE”q ºgfff‰ð‰÷Áÿ÷êÁú)úJ‰•ÿÿÿˆíU”u‰•ÿÿÿ»d‰µÿÿÿ‰½Dÿÿÿv‹U”‰ÈƒÂ 9Ñ~‰Ð‰E‹UŒ¿‹‰ƒh‹µDÿÿÿ‰4$èüÿÿÿ‰|$‹ÿÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿº‹µÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x9‹|ÿÿÿt‘ü´&¼'‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE” ÿÿÿÿx ‹Eˆ‹é4ÿÿÿ‹MŒ»´‹1‰³¸‰<$èüÿÿÿèüÿÿÿÄ[^_]Ãø"‰ÈƒÀˆWÇE”ÁøH‰… ÿÿÿx°E”u‰…ÿÿÿ»x‰µÿÿÿ‰½tÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ|‹µtÿÿÿ‰4$èüÿÿÿ‰|$‹ÿÿÿ‹•dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿ¸‹µÿÿÿ‰D$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x/‹|ÿÿÿt‘üt&‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ ÿÿÿˆÖþÿÿ‹Uˆ‹ é:ÿÿÿ‰Ð÷؃ø#ÇE”q¿gfff‰ð÷ï‰ðÁøÑú)ÂJ‰•@ÿÿÿˆ–þÿÿ»u”‰½\ÿÿÿU‰µ`ÿÿÿ‰•pÿÿÿ‰M‹E”ƒÀ9Á~‰E‹EŒ‹8‰»‹µ\ÿÿÿ¿‰4$èüÿÿÿ‹`ÿÿÿº‹…dÿÿÿ‰T$‰L$‰$èüÿÿÿ‰|$‹•dÿÿÿ‹µpÿÿÿ‰$‰t$èüÿÿÿ‹M‹U”‰Ï)×x6‹|ÿÿÿt‘üt&¼'‰t$‹•dÿÿÿ¸‰D$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ@ÿÿÿˆ¶ýÿÿ‹Eˆ‹é4ÿÿÿƒø ÇE”qº«ªª*‰ð‰÷Áÿ÷ê)úJ‰•ÿÿÿˆ|ýÿÿU”u‰•üþÿÿ»Œ‰µøþÿÿ‰½Tÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ‹µTÿÿÿ‰4$èüÿÿÿ‰|$‹üþÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿº‹µøþÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x+‹|ÿÿÿt‘ü‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿÿÿÿˆ¦üÿÿ‹Eˆ‹é>ÿÿÿƒø‰ÈƒÀˆ"ÇE”ÁøH‰…<ÿÿÿˆqüÿÿU”}‰•8ÿÿÿ³(‰½4ÿÿÿ‰µxÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¾‹‰ƒ,‹½xÿÿÿ‰<$èüÿÿÿ‰t$‹8ÿÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½4ÿÿÿº‹µdÿÿÿ‰T$‰|$‰4$èüÿÿÿ‹M‹U”‰Ï)×x0‹|ÿÿÿt‘üt&‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ<ÿÿÿˆ–ûÿÿ‹Eˆ‹é9ÿÿÿÇE”qºgfff‰ð‰÷Áÿ÷êÑú)úJ‰•ôþÿÿˆcûÿÿU”u‰•ðþÿÿ» ‰µìþÿÿ‰½Hÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ¤‹µHÿÿÿ‰4$èüÿÿÿ‰|$‹ðþÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿº‹µìþÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x2‹|ÿÿÿt‘ü´&‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿôþÿÿˆ†úÿÿ‹Eˆ‹é7ÿÿÿƒø ÇE”qºVUUU‰ð‰÷Áÿ÷ê)úJ‰•0ÿÿÿˆLúÿÿU”u‰•,ÿÿÿ»<‰µ(ÿÿÿ‰½Lÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ@‹µLÿÿÿ‰4$èüÿÿÿ‰|$‹,ÿÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿº‹µ(ÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x+‹|ÿÿÿt‘ü‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ0ÿÿÿˆvùÿÿ‹Eˆ‹é>ÿÿÿAé¡ùÿÿÇE”y‰þÁî÷ÑÿO‰½$ÿÿÿˆDùÿÿ}”U‰½ ÿÿÿƒP‰•ÿÿÿ‰…Pÿÿÿ‹U”‰ÈB9Ñ~‰Ð‰E‹uŒ‹>‰»T‹•Pÿÿÿ¿‰$èüÿÿÿ‹ ÿÿÿ¸‹µdÿÿÿ‰D$‰L$‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…dÿÿÿ‰T$‰$èüÿÿÿ‹M‹U”‰Ï)×x+‹|ÿÿÿt‘ü‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ$ÿÿÿˆpøÿÿ‹uˆ‹é@ÿÿÿAéÖûÿÿ(/,1X,A,/,1X,A)(1X,I4, - ,I4,:,1P,10E12.3)(1X,I4, - ,I4,:,1X,1P,8E14.5)(1X,I4, - ,I4,:,1X,1P,6E18.9)(1X,I4, - ,I4,:,1X,1P,5E24.13)(1X, )@€À@€Àâ- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@  ìH %` ê +L 4L È0 4P D L Y €  #C ™40 d†ñÿ .?S(d@!x<‰€!P®À"ÂdÔxæŒø  ´â  1 6 = Tjqxsvout.f__g77_cilist_0.1__g77_format_9999.0__g77_cilist_1.3__g77_format_9998.2__g77_cilist_2.5__g77_format_9997.4__g77_cilist_3.7__g77_format_9996.6__g77_cilist_4.9__g77_format_9995.8__g77_cilist_5.10__g77_cilist_6.11__g77_cilist_7.12__g77_cilist_8.13__g77_cilist_9.15__g77_format_9994.14.LC2svout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfe R Ÿ ÑÝ å í ö !.!3" Í Û ÷!!Z!b" ‰ ‘ –"Ú   1!R!Š!’"è  . O!k!ª!²" ; I e!†!º!Â" F T p!‘!Ê!Ò"' T b ~!Ÿ!Ú!â"> k y •!¶!ê!ò"F l     !¼ !ð !ø "  4H\p„˜¬Àsmout.o/ 1189291773 1000 1000 100644 8700 ` ELF|4( U‰åWVSì‹U ‹MèüÿÿÿËu‹E‰UŒ‹U$‰M„‹}‰µhÿÿÿƒúP‰E‹‰}ˆ‰U€‰…|ÿÿÿ‰•pÿÿÿ~ ¹P‰pÿÿÿu˜‰µ,ÿÿÿ‹µpÿÿÿNxDÇE”»ë‰E”‰|$¹‹•,ÿÿÿ‰L$ ‹M”¸‰D$D ÿ‰$èüÿÿÿ‹E”@NyË‹µpÿÿÿF‰÷‰u”÷׉þƒÆQx7»‰|$¹‹•,ÿÿÿ‰L$ ‹M”¸‰D$D ÿ‰$èüÿÿÿÿE”NyÏ‹}ƒ‹»‰‹‰$èüÿÿÿ‰½ ÿÿÿ‹U€‹u ‰<$‰T$‰t$èüÿÿÿ‹pÿÿÿ‹• ÿÿÿ‹…,ÿÿÿ‰L$‰$‰D$èüÿÿÿèüÿÿÿ‹uŒ‹>…ÿŽ{‹uˆ‹…ÉŽn‹U„‹…ÀŽa‹}‹…À‰Âu¸…ÒˆOƒøKq ºgfff‰ð÷ê‰÷Áÿ¾‰µTþÿÿÁú)úJ‰•Xþÿÿˆô»´‰½$ÿÿÿ‰Pþÿÿ‹…TþÿÿƒÀ 9Á~‰…Pþÿÿ‹}‹‰ƒ¸‹•$ÿÿÿ‰$èüÿÿÿ‹Tþÿÿ‹µPþÿÿ‰M”)Îxk“‹‰•Lþÿÿ}”‰Hþÿÿ´&¼'‹•Hþÿÿ¹‹…Lþÿÿ‰L$‰$‰D$èüÿÿÿ‰|$‹… ÿÿÿ¹‰L$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}Œ‹7ÇE”N‰µDþÿÿˆE”‹µTþÿÿ‹•Tþÿÿ‰…@þÿÿ‹½Pþÿÿ‹È‰ÿÿÿ‹…|ÿÿÿ µüÿÿÿ)ׯȋ•|ÿÿÿ‰½XÿÿÿÁâ‰ìþÿÿ‰•Ìþÿÿ¶¿‹u‹‰ƒÌ‹ÿÿÿ‰ $èüÿÿÿ‹½@þÿÿº‹µ ÿÿÿ‰T$‰|$‰4$èüÿÿÿ‹½Xÿÿÿ…ÿxI‹µìþÿÿ‹•hÿÿÿÖ´&¼'‹M”¸‰D$‹… ÿÿÿTŽü‰T$‰$èüÿÿÿ‹ÌþÿÿÎOyÓèüÿÿÿÿE”ÿDþÿÿ‰_ÿÿÿƒ…Tþÿÿ ÿXþÿÿx ‹uˆ‹éþÿÿ‹U»T‹2‰³X‰<$èüÿÿÿèüÿÿÿÄ[^_]Ãø‰ÈƒÀˆ Áø¿H‰½8þÿÿ‰…<þÿÿx¬³Ü‰µ(ÿÿÿ‰4þÿÿ‹…8þÿÿƒÀ9Á~‰…4þÿÿ‹u‹>‰»à‹…(ÿÿÿ‰$èüÿÿÿ‹8þÿÿ‹µ4þÿÿ‰M”)Îx]‹“‰0þÿÿ}”‰•,þÿÿ‹,þÿÿº‹…0þÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹… ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹uŒ‹>ÇE”O‰½(þÿÿˆç}”‹4þÿÿ‹µ8þÿÿ‰½$þÿÿ‹•8þÿÿƒð‰…0ÿÿÿ‹½|ÿÿÿ)ñ‰Tÿÿÿ•üÿÿÿ¯Ç‹|ÿÿÿÁቅðþÿÿ‰Ðþÿÿ‹U¾‹:‰»ô‹…0ÿÿÿ‰$èüÿÿÿ‰t$‹$þÿÿ‹• ÿÿÿ‰L$‰$èüÿÿÿ‹½Tÿÿÿ…ÿx;‹µðþÿÿ‹hÿÿÿκ‹E”‰T$‹• ÿÿÿL†ü‰L$‰$èüÿÿÿ‹…ÐþÿÿÆOyÓèüÿÿÿÿE”ÿ(þÿÿ‰mÿÿÿƒ…8þÿÿÿ<þÿÿˆæýÿÿ‹Uˆ‹ é<þÿÿ‰Ð÷؃øyºgfff‰ø÷ê‰øÁø¾‰µxÿÿÿÑú)ÂJ‰•¸þÿÿˆ¢ýÿÿ³‰µ8ÿÿÿ‰tÿÿÿ‹…xÿÿÿƒÀ9Á~‰…tÿÿÿ‹u‹‰ƒ‹•8ÿÿÿ‰$èüÿÿÿ‹xÿÿÿ‹µtÿÿÿ‰M”)Îx]»‹‰½ÿÿÿ}”‰ÿÿÿ‹•ÿÿÿ¸‹ÿÿÿ‰D$‰T$‰ $èüÿÿÿ‰|$‹• ÿÿÿ¸‰D$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}Œ‹7ÇE”N‰µ´þÿÿˆíE”‹µxÿÿÿ‹xÿÿÿ‰…°þÿÿ‹½tÿÿÿ“(‰•@ÿÿÿ‹…|ÿÿÿµüÿÿÿ)ϯЋ|ÿÿÿ‰½lÿÿÿÁቕÜþÿÿ‰¼þÿÿ‹u‹‰ƒ,‹•@ÿÿÿ‰$èüÿÿÿ‹½°þÿÿ¹‹µ ÿÿÿ‰L$‰|$‰4$èüÿÿÿ‹½lÿÿÿ…ÿxA‹µÜþÿÿ‹hÿÿÿζ‹U”¸‰D$‹… ÿÿÿL–ü‰L$‰$èüÿÿÿ‹•¼þÿÿÖOyÓèüÿÿÿÿE”ÿ´þÿÿ‰gÿÿÿƒ…xÿÿÿÿ¸þÿÿˆÖûÿÿ‹}ˆ‹é6þÿÿƒø qº«ªª*‰ð÷ê‰÷Áÿ¾‰µþÿÿ)úJ‰• þÿÿˆ˜ûÿÿ»‰½Dÿÿÿ‰þÿÿ‹…þÿÿƒÀ9Á~‰…þÿÿ‹}‹‰ƒ‹•Dÿÿÿ‰$èüÿÿÿ‹þÿÿ‹µþÿÿ‰M”)Îx]“‹‰•þÿÿ}”‰þÿÿ‹•þÿÿ¹‹…þÿÿ‰L$‰$‰D$èüÿÿÿ‰|$‹… ÿÿÿ¹‰L$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}Œ‹7ÇE”N‰µ þÿÿˆóM”‹µþÿÿ‹•þÿÿ‰þÿÿ‹½þÿÿƒ‰…ÿÿÿ‹|ÿÿÿµüÿÿÿ)ׯÁ‹•|ÿÿÿ‰½PÿÿÿÁ≅ôþÿÿ‰•Ôþÿÿ‹u‹‰‹‹…ÿÿÿ‰$èüÿÿÿ‹½þÿÿº‹µ ÿÿÿ‰T$‰|$‰4$èüÿÿÿ‹½Pÿÿÿ…ÿxG‹µôþÿÿ‹•hÿÿÿÖ¶¿¹‹E”‰L$‹ ÿÿÿT†ü‰T$‰ $èüÿÿÿ‹…ÔþÿÿÆOyÓèüÿÿÿÿE”ÿ þÿÿ‰aÿÿÿƒ…þÿÿÿ þÿÿˆÆùÿÿ‹uˆ‹é0þÿÿqºgfff‰ð÷ê‰ðÁø¿‰½þÿÿÑú)ÂJ‰•þÿÿˆùÿÿ»,‰½ ÿÿÿ‰üýÿÿ‹…þÿÿƒÀ9Á~‰…üýÿÿ‹}‹‰ƒ0‹• ÿÿÿ‰$èüÿÿÿ‹þÿÿ‹µüýÿÿ‰M”)Îx]“‹‰•øýÿÿ}”‰ôýÿÿ‹•ôýÿÿ¹‹…øýÿÿ‰L$‰$‰D$èüÿÿÿ‰|$‹… ÿÿÿ¹‰L$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}Œ‹7ÇE”N‰µðýÿÿˆêM”‹µþÿÿ‹•þÿÿ‰ìýÿÿ‹½üýÿÿƒ@‰…ÿÿÿ‹|ÿÿÿµüÿÿÿ)ׯÁ‹•|ÿÿÿ‰½LÿÿÿÁ≅øþÿÿ‰•Øþÿÿ‹u‹‰‹D‹…ÿÿÿ‰$èüÿÿÿ‹½ìýÿÿº‹µ ÿÿÿ‰T$‰|$‰4$èüÿÿÿ‹½Lÿÿÿ…ÿx>‹µøþÿÿ‹•hÿÿÿÖv¹‹E”‰L$‹ ÿÿÿT†ü‰T$‰ $èüÿÿÿ‹…ØþÿÿÆOyÓèüÿÿÿÿE”ÿðýÿÿ‰jÿÿÿƒ…þÿÿÿþÿÿˆÆ÷ÿÿ‹uˆ‹é9þÿÿƒø÷‰ÈƒÀyAÁø¿H‰½¨þÿÿ‰…¬þÿÿˆŽ÷ÿÿ³<‰µHÿÿÿ‰¤þÿÿ‹…¨þÿÿƒÀ9Á~‰…¤þÿÿ‹u‹>‰»@‹…Hÿÿÿ‰$èüÿÿÿ‹¨þÿÿ‹µ¤þÿÿ‰M”)Îx]‹“‰ þÿÿ}”‰•œþÿÿ‹œþÿÿº‹… þÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹… ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹uŒ‹>ÇE”O‰½˜þÿÿˆé}”‹¤þÿÿ‹µ¨þÿÿ‰½”þÿÿ‹•¨þÿÿƒP‰…4ÿÿÿ‹½|ÿÿÿ)ñ‰dÿÿÿ•üÿÿÿ¯Ç‹|ÿÿÿÁቅàþÿÿ‰Àþÿÿ‹U¾‹:‰»T‹…4ÿÿÿ‰$èüÿÿÿ‰t$‹”þÿÿ‹• ÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿ…ÿx=‹µàþÿÿ‹hÿÿÿÎfº‹E”‰T$‹• ÿÿÿL†ü‰L$‰$èüÿÿÿ‹…ÀþÿÿÆOyÓèüÿÿÿÿE”ÿ˜þÿÿ‰kÿÿÿƒ…¨þÿÿÿ¬þÿÿˆÆõÿÿ‹Uˆ‹ é:þÿÿƒø ýqºVUUU‰ð÷ê‰÷Áÿ¾‰µŒþÿÿ)úJ‰•þÿÿˆˆõÿÿ»d‰½<ÿÿÿ‹…Œþÿÿ‰ÏƒÀ9Á~‰Ç‹u‹‰þ‰ƒh‹•<ÿÿÿ‰$èüÿÿÿ‹Œþÿÿ)ΉM”xiƒ“‰…ˆþÿÿM”‰•„þÿÿ‰€þÿÿ‹•ˆþÿÿ¸‹„þÿÿ‰D$‰T$‰ $èüÿÿÿ‹•€þÿÿ¸‹ ÿÿÿ‰D$‰T$‰ $èüÿÿÿÿE”Ny¸èüÿÿÿ‹MŒ‹1ÇE”N‰µ|þÿÿˆáU”‹Œþÿÿ‹µŒþÿÿ‰•xþÿÿ‹•|ÿÿÿƒx‰…üþÿÿ)ϵüÿÿÿ‰½`ÿÿÿ¯Â‹½|ÿÿÿ‰…äþÿÿÁ牽Äþÿÿ‹U‹:‰»|‹…üþÿÿ‰$èüÿÿÿ‹½ ÿÿÿ¹‹µxþÿÿ‰L$‰<$‰t$èüÿÿÿ‹½`ÿÿÿ…ÿx;‹µäþÿÿ‹hÿÿÿκ‹E”‰T$‹• ÿÿÿL†ü‰L$‰$èüÿÿÿ‹…ÄþÿÿÆOyÓèüÿÿÿÿE”ÿ|þÿÿ‰mÿÿÿƒ…ŒþÿÿÿþÿÿˆÈóÿÿ‹uˆ‹éBþÿÿAéóóÿÿq¿‰ð‰½pþÿÿÁèÆÑþN‰µtþÿÿˆ’óÿÿ“Œ‰•ÿÿÿ‹…pþÿÿ‰Ï@9Á~‰Ç‹U‹2‰³‹…ÿÿÿ‰þ‰$èüÿÿÿ‹pþÿÿ)ΉM”xi“ƒ‰•lþÿÿM”‰…hþÿÿ‰dþÿÿ‹hþÿÿº‹…lþÿÿ‰T$‰ $‰D$èüÿÿÿ‹…dþÿÿº‹ ÿÿÿ‰T$‰D$‰ $èüÿÿÿÿE”Ny¸èüÿÿÿ‹MŒ‹1ÇE”N‰µ`þÿÿˆáU”‹pþÿÿ‹µpþÿÿ‰•\þÿÿ‹•|ÿÿÿƒ ‰…ÿÿÿ)ϵüÿÿÿ‰½\ÿÿÿ¯Â‹½|ÿÿÿ‰…èþÿÿÁ牽Èþÿÿ‹U‹:‰»¤‹…ÿÿÿ‰$èüÿÿÿ‹½ ÿÿÿ¹‹µ\þÿÿ‰L$‰<$‰t$èüÿÿÿ‹½\ÿÿÿ…ÿx;‹µèþÿÿ‹hÿÿÿκ‹E”‰T$‹• ÿÿÿL†ü‰L$‰$èüÿÿÿ‹…ÈþÿÿÆOyÓèüÿÿÿÿE”ÿ`þÿÿ‰mÿÿÿƒ…pþÿÿÿtþÿÿˆÔñÿÿ‹uˆ‹éDþÿÿCol(/,1X,A,/,1X,A)(10X,10(4X,3A1,I4,1X))(10X,8(5X,3A1,I4,2X))(10X,6(7X,3A1,I4,4X))(10X,5(9X,3A1,I4,6X))(1X, Row,I4,:,1X,1P,10E12.3)(1X, Row,I4,:,1X,1P,8E14.5)(1X, Row,I4,:,1X,1P,6E18.9)(1X, Row,I4,:,1X,1P,5E22.13)(1X, )€( =ÀRà€( =ÀRà- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ d %@ +H4Hh0 l! D°L´Y¼€ÀÀ#ã™Ô* äñÿ !5FZ(k€ <(¤P¶ ÊdÜ=ñxÀŒ*R? Qà f´xÈ‹Üžð±Ä×,ê@ýT  %* /6 Mcjqxsmout.ficol.0__g77_cilist_0.2__g77_format_9999.1__g77_cilist_1.4__g77_format_9998.3__g77_cilist_2.6__g77_format_9994.5__g77_cilist_3.8__g77_format_9997.7__g77_cilist_4.10__g77_format_9993.9__g77_cilist_5.12__g77_format_9996.11__g77_cilist_6.14__g77_format_9992.13__g77_cilist_7.16__g77_format_9995.15__g77_cilist_8.18__g77_format_9991.17__g77_cilist_9.19__g77_cilist_10.20__g77_cilist_11.21__g77_cilist_12.22__g77_cilist_13.23__g77_cilist_14.24__g77_cilist_15.25__g77_cilist_16.26__g77_cilist_17.28__g77_format_9990.27.LC2.LC3smout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfe+ ,w #§-É #ô-   ' .5/W/\0Ø  .) / (m/ˆ/“0Í  %.F/Ž/ž0Ï × ß.ä0  J X.q w (§/Â/Í0 J X.t/®/¾0* T b.{ ( ±/Ì/×0 O ].~/¾/Î04 ^ l.… ‹ (»/Ö/á0 Y g .ˆ /Î /Þ 0= g u .Ž ” (Ä /ß /ê 0$ b p .‘ /Î /Þ 0> h v . • (Å /à /ë 0% h v .’ /Î /Þ 0D h v.‰  (Å/æ/ñ0+ c q.’/Ì/Ü0: Z j.} ƒ (¹/Ú/å0 W e.†/À/Ð0  4H\p„˜¬ÀÔèü$8L`icnteq.o/ 1189291773 1000 1000 100644 730 ` ELFà4( U‰å‹EWV‹1öIx ‹U‹:‹U ‰ö¼'1À9:”ÀƃÂIyñ‰ð^_]ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.text.data.bss.note.GNU-stack.comment@5!x'x,x<x#›EH€ Èñÿ 5icnteq.ficnteq_icopy.o/ 1189291773 1000 1000 100644 876 ` ELFt4( U‰åWVƒì‹U‹E‹M ‹u‰Uð‹‰Mô…Ò~a‹}‹ƒùt^‹>ÇEì…ÉÇEèxk…ÿxy‰ÖNx:‹EèÁá‹Uð‰MäÁç‰}àL‚ü‹}ì‹EôT¸ü‰ö¼'‹:‰9‹Eä‹}àÂùNyïƒÄ^_]Ë>ƒÿu‰ÖNxí‹Mð‹Uô‹ƒÂ‰ƒÁNyóëؾ)Ö¯ñF…ÿ‰uìy‡‹Eè)ЯÇ@‰EèévÿÿÿGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.text.data.bss.note.GNU-stack.comment@Ì! ' , < #/EÜ€ \ñÿ Ìicopy.ficopy_iset.o/ 1189291773 1000 1000 100644 714 ` ELFÔ4( U‰å‹E‹Ix‹U ‹‹U¶¼'‰ƒÂIyø]ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.text.data.bss.note.GNU-stack.comment@*!l'l,l<l#E<€ ¼ñÿ*iset.fiset_iswap.o/ 1189291773 1000 1000 100644 1044 ` ELF4( U‰åWVƒìD‹M‹U‹E ‰Mô‹9‰Uè‹U…ÿ‰Eð~r‹M‰Mì‹1ƒþtl‹‰EØÇEà…öÇE¼ˆû‹UØ…Òˆ Ox<Áæ‹M¼‹Eè‰u´‹uØ‹UàÁæ‰u¸tˆü‹EðLüt&‹‹‰‰‹E´‹U¸ÁÖOyëƒÄD^_]ˉUØJu‘¸VUUU÷ï‰Ñ‰úÁú)Ñ4I‰ù)ñ‰MÔt$I‰MÜx‹Mè‹uð‹‹‰ƒÁ‰ƒÆÿMÜyíƒÿ~±‹MÔ¾VUUUA)σljø÷îÁÿ‰Ö)þN‰uÌx’‹}ð‹Mè4 :‹Qü‹~ü‹‰Vü‹‰yü‹~‰‹A‰‰yƒÁ ‰FƒÆ ÿMÌyÕéOÿÿÿ¹‹UØ)ù¯ÎA…Ò‰Mà‰÷þÿÿ‹M¼‹EØ)ù¯ÈA‰M¼éãþÿÿGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.text.data.bss.note.GNU-stack.comment@s!´'´,´<´#×E„€ ñÿ siswap.fiswap_ivout.o/ 1189291774 1000 1000 100644 5460 ` ELF¬ 4( U‰åWVSì‹U‹uèüÿÿÿËM ‹EƒúP‰uŒ‰Mˆ‰…|ÿÿÿ‰U„‰U€~ÇE€P‹u€E˜‰…HÿÿÿNx8»‰½dÿÿÿ‰Çf‰<$‹•dÿÿÿ¹‰L$ ¸G‰D$‰T$èüÿÿÿNyØ‹E€@‰Æ÷Ö‰÷ƒÇQxA‹•Hÿÿÿ‹‰`ÿÿÿtÿv‰4$‹…`ÿÿÿ¹‰L$ ºF‰T$‰D$èüÿÿÿOyØ‹UŒƒ‹ ‰‹‰$èüÿÿÿ‹u„‹‹}‰\ÿÿÿ‰ $‰t$‰|$èüÿÿÿ‹U€‹…Hÿÿÿ‹µ\ÿÿÿ‰T$‰D$‰4$èüÿÿÿèüÿÿÿ‹}ˆ‹…ÉŽV‹}‹…À‰Âu¸…Òˆdƒø@ÇE”qºgfff‰ð‰÷Áÿ÷êÁú)úJ‰•ÿÿÿˆíU”u‰•ÿÿÿ»d‰µÿÿÿ‰½Lÿÿÿv‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒh‹µLÿÿÿ‰4$èüÿÿÿ‰|$‹ÿÿÿ‹…\ÿÿÿ‰L$‰$èüÿÿÿ‹½\ÿÿÿº‹µÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x9‹|ÿÿÿt‘ü´&¼'‰t$‹…\ÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿÿÿÿx ‹Eˆ‹é4ÿÿÿ‹MŒ»´‹1‰³¸‰<$èüÿÿÿèüÿÿÿÄ[^_]Ãø2ÇE”qº‰ˆˆˆ‰ð‰÷Áÿ÷êòÁú)úJ‰• ÿÿÿx¦U”u‰•ÿÿÿ»x‰µÿÿÿ‰½pÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ|‹µpÿÿÿ‰4$èüÿÿÿ‰|$‹ÿÿÿ‹…\ÿÿÿ‰L$‰$èüÿÿÿ‹½\ÿÿÿº‹µÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x5‹|ÿÿÿt‘üv¼'‰t$‹…\ÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ ÿÿÿˆÆþÿÿ‹Eˆ‹é4ÿÿÿ‰Ð÷؃ø3ÇE”q ¿gfff‰ð÷ï‰ðÁøÁú)ÂJ‰•@ÿÿÿˆ…þÿÿ»u”‰½xÿÿÿU‰µPÿÿÿ‰•Xÿÿÿ‰M‹E”ƒÀ 9Á~‰E‹EŒ‹8‰»‹µxÿÿÿ¿‰4$èüÿÿÿ‹Pÿÿÿº‹…\ÿÿÿ‰T$‰L$‰$èüÿÿÿ‰|$‹•\ÿÿÿ‹µXÿÿÿ‰$‰t$èüÿÿÿ‹M‹U”‰Ï)×x5‹|ÿÿÿt‘üv¼'‰t$‹•\ÿÿÿ¸‰D$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE” ÿ@ÿÿÿˆ¦ýÿÿ‹Eˆ‹é5ÿÿÿƒø 2ÇE”q ºgfff‰ð‰÷Áÿ÷êÁú)úJ‰•ÿÿÿˆiýÿÿU”u‰•üþÿÿ»Œ‰µøþÿÿ‰½Tÿÿÿ‹U”‰ÈƒÂ 9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ‹µTÿÿÿ‰4$èüÿÿÿ‰|$‹üþÿÿ‹…\ÿÿÿ‰L$‰$èüÿÿÿ‹½\ÿÿÿº‹µøþÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x8‹|ÿÿÿt‘ü¶¼'‰t$‹…\ÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE” ÿÿÿÿˆ†üÿÿ‹Eˆ‹é1ÿÿÿƒøŽ'ƒø .ÇE”qºgfff‰ð‰÷Áÿ÷êÑú)úJ‰•0ÿÿÿˆAüÿÿU”u‰•,ÿÿÿ»<‰µ(ÿÿÿ‰½hÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ@‹µhÿÿÿ‰4$èüÿÿÿ‰|$‹,ÿÿÿ‹…\ÿÿÿ‰L$‰$èüÿÿÿ‹½\ÿÿÿº‹µ(ÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x+‹|ÿÿÿt‘ü‰t$‹…\ÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ0ÿÿÿˆkûÿÿ‹Eˆ‹é>ÿÿÿÇE”qº“$I’‰ð‰÷Áÿ÷êòÁú)úJ‰•ôþÿÿˆ5ûÿÿU”u‰•ðþÿÿ» ‰µìþÿÿ‰½tÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ¤‹µtÿÿÿ‰4$èüÿÿÿ‰|$‹ðþÿÿ‹…\ÿÿÿ‰L$‰$èüÿÿÿ‹½\ÿÿÿº‹µìþÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x4‹|ÿÿÿt‘ü‰ö¼'‰t$‹…\ÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿôþÿÿˆVúÿÿ‹Eˆ‹é5ÿÿÿÇE”qº“$I’‰ð‰÷Áÿ÷êòÁú)úJ‰•<ÿÿÿˆ úÿÿU”u‰•8ÿÿÿ»(‰µ4ÿÿÿ‰½lÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ,‹µlÿÿÿ‰4$èüÿÿÿ‰|$‹8ÿÿÿ‹…\ÿÿÿ‰L$‰$èüÿÿÿ‹½\ÿÿÿº‹µ4ÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x/‹|ÿÿÿt‘üt&‰t$‹…\ÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ<ÿÿÿˆFùÿÿ‹Eˆ‹é:ÿÿÿÇE”qºVUUU‰ð‰÷Áÿ÷ê)úJ‰•$ÿÿÿˆùÿÿU”u‰• ÿÿÿ»P‰µÿÿÿ‰½Dÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒT‹µDÿÿÿ‰4$èüÿÿÿ‰|$‹ ÿÿÿ‹…\ÿÿÿ‰L$‰$èüÿÿÿ‹½\ÿÿÿº‹µÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x+‹|ÿÿÿt‘ü‰t$‹…\ÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ$ÿÿÿˆ?øÿÿ‹Eˆ‹é>ÿÿÿ(/,1X,A,/,1X,A)(1X,I4, - ,I4,:,20(1X,I5))(1X,I4, - ,I4,:,15(1X,I7))(1X,I4, - ,I4,:,10(1X,I11))(1X,I4, - ,I4,:,7(1X,I15))(1X, )-Lk-Lk‰- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@G  ¼H %ˆ ‘+ 4 È0 P Dä Lè Yì €ð ð # ™0 4†ñÿ .?S(d-x<‰LP®kÂdÔxæŒø  ´‰  1 6G = Tjqxivout.f__g77_cilist_0.1__g77_format_2000.0__g77_cilist_1.3__g77_format_1000.2__g77_cilist_2.5__g77_format_1001.4__g77_cilist_3.7__g77_format_1002.6__g77_cilist_4.9__g77_format_1003.8__g77_cilist_5.10__g77_cilist_6.11__g77_cilist_7.12__g77_cilist_8.13__g77_cilist_9.15__g77_format_1004.14.LC2ivout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfe R Ÿ ÑÝ å í ö !.!3" Í Û ÷!!Z!b" ‰ ‘ –"ä   ;!\!š!¢"ù , ? `!|!º!Â"! N \ x!™!Ú!â"I v „  !Á!õ!ý"U ‚  ¬!Í! !"j — ¥ Á!â! !" "u ¢ °  Ì !í !! !) "  4H\p„˜¬Àarscnd.o/ 1189291774 1000 1000 100644 992 ` ELF4( U‰åMèSƒì$èüÿÿÿÉ $èüÿÿÿÝØ‹Uè‹E‰ƒÄ$[]Ë$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@- È %p+p0pWtgt#—pÀÀ  €Fñÿ -)?arscnd.farscnd___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_etime_    dvout.o/ 1189291774 1000 1000 100644 5508 ` ELFÜ 4( U‰åWVSì‹U‹uèüÿÿÿËM ‹EƒúP‰uŒ‰Mˆ‰…|ÿÿÿ‰U„‰U€~ÇE€P‹u€E˜‰…XÿÿÿNx8»‰½lÿÿÿ‰Çf‰<$‹•lÿÿÿ¹‰L$ ¸G‰D$‰T$èüÿÿÿNyØ‹E€@‰Æ÷Ö‰÷ƒÇQxA‹•Xÿÿÿ‹‰hÿÿÿtÿv‰4$‹…hÿÿÿ¹‰L$ ºF‰T$‰D$èüÿÿÿOyØ‹UŒƒ‹ ‰‹‰$èüÿÿÿ‹u„‹‹}‰dÿÿÿ‰ $‰t$‰|$èüÿÿÿ‹U€‹…Xÿÿÿ‹µdÿÿÿ‰T$‰D$‰4$èüÿÿÿèüÿÿÿ‹}ˆ‹…ÉŽV‹}‹…À‰Âu¸…ÒˆTƒø@ÇE”q ºgfff‰ð‰÷Áÿ÷êÁú)úJ‰•ÿÿÿˆíU”u‰•ÿÿÿ»d‰µÿÿÿ‰½Dÿÿÿv‹U”‰ÈƒÂ 9Ñ~‰Ð‰E‹UŒ¿‹‰ƒh‹µDÿÿÿ‰4$èüÿÿÿ‰|$‹ÿÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿº‹µÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x9‹|ÿÿÿtÑø´&¼'‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE” ÿÿÿÿx ‹Eˆ‹é4ÿÿÿ‹MŒ»´‹1‰³¸‰<$èüÿÿÿèüÿÿÿÄ[^_]Ãø"‰ÈƒÀˆWÇE”ÁøH‰… ÿÿÿx°E”u‰…ÿÿÿ»x‰µÿÿÿ‰½tÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ|‹µtÿÿÿ‰4$èüÿÿÿ‰|$‹ÿÿÿ‹•dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿ¸‹µÿÿÿ‰D$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x/‹|ÿÿÿtÑøt&‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ ÿÿÿˆÖþÿÿ‹Uˆ‹ é:ÿÿÿ‰Ð÷؃ø#ÇE”q¿gfff‰ð÷ï‰ðÁøÑú)ÂJ‰•@ÿÿÿˆ–þÿÿ»u”‰½\ÿÿÿU‰µ`ÿÿÿ‰•pÿÿÿ‰M‹E”ƒÀ9Á~‰E‹EŒ‹8‰»‹µ\ÿÿÿ¿‰4$èüÿÿÿ‹`ÿÿÿº‹…dÿÿÿ‰T$‰L$‰$èüÿÿÿ‰|$‹•dÿÿÿ‹µpÿÿÿ‰$‰t$èüÿÿÿ‹M‹U”‰Ï)×x6‹|ÿÿÿtÑøt&¼'‰t$‹•dÿÿÿ¸‰D$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ@ÿÿÿˆ¶ýÿÿ‹Eˆ‹é4ÿÿÿƒø ÇE”qº«ªª*‰ð‰÷Áÿ÷ê)úJ‰•ÿÿÿˆ|ýÿÿU”u‰•üþÿÿ»Œ‰µøþÿÿ‰½Tÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ‹µTÿÿÿ‰4$èüÿÿÿ‰|$‹üþÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿº‹µøþÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x+‹|ÿÿÿtÑø‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿÿÿÿˆ¦üÿÿ‹Eˆ‹é>ÿÿÿƒø‰ÈƒÀˆ"ÇE”ÁøH‰…<ÿÿÿˆqüÿÿU”}‰•8ÿÿÿ³(‰½4ÿÿÿ‰µxÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¾‹‰ƒ,‹½xÿÿÿ‰<$èüÿÿÿ‰t$‹8ÿÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½4ÿÿÿº‹µdÿÿÿ‰T$‰|$‰4$èüÿÿÿ‹M‹U”‰Ï)×x0‹|ÿÿÿtÑøt&‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ<ÿÿÿˆ–ûÿÿ‹Eˆ‹é9ÿÿÿÇE”qºgfff‰ð‰÷Áÿ÷êÑú)úJ‰•ôþÿÿˆcûÿÿU”u‰•ðþÿÿ» ‰µìþÿÿ‰½Hÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ¤‹µHÿÿÿ‰4$èüÿÿÿ‰|$‹ðþÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿº‹µìþÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x2‹|ÿÿÿtÑø´&‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿôþÿÿˆ†úÿÿ‹Eˆ‹é7ÿÿÿƒø ÇE”qºVUUU‰ð‰÷Áÿ÷ê)úJ‰•0ÿÿÿˆLúÿÿU”u‰•,ÿÿÿ»<‰µ(ÿÿÿ‰½Lÿÿÿ‹U”‰ÈƒÂ9Ñ~‰Ð‰E‹UŒ¿‹‰ƒ@‹µLÿÿÿ‰4$èüÿÿÿ‰|$‹,ÿÿÿ‹…dÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿº‹µ(ÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)×x+‹|ÿÿÿtÑø‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ0ÿÿÿˆvùÿÿ‹Eˆ‹é>ÿÿÿAé¡ùÿÿÇE”y‰þÁî÷ÑÿO‰½$ÿÿÿˆDùÿÿ}”U‰½ ÿÿÿƒP‰•ÿÿÿ‰…Pÿÿÿ‹U”‰ÈB9Ñ~‰Ð‰E‹uŒ‹>‰»T‹•Pÿÿÿ¿‰$èüÿÿÿ‹ ÿÿÿ¸‹µdÿÿÿ‰D$‰L$‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…dÿÿÿ‰T$‰$èüÿÿÿ‹M‹U”‰Ï)×x+‹|ÿÿÿtÑø‰t$‹…dÿÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿ$ÿÿÿˆpøÿÿ‹uˆ‹é@ÿÿÿAéÖûÿÿ(/,1X,A,/,1X,A)(1X,I4, - ,I4,:,1P,10D12.3)(1X,I4, - ,I4,:,1X,1P,8D14.5)(1X,I4, - ,I4,:,1X,1P,6D18.9)(1X,I4, - ,I4,:,1X,1P,5D24.13)(1X, )@€À@€Àâ- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@  ìH %` ê +L 4L È0 4P D L Y €  #C ™40 d†ñÿ .?S(d@!x<‰€!P®À"ÂdÔxæŒø  ´â  1 6 = Tjqxdvout.f__g77_cilist_0.1__g77_format_9999.0__g77_cilist_1.3__g77_format_9998.2__g77_cilist_2.5__g77_format_9997.4__g77_cilist_3.7__g77_format_9996.6__g77_cilist_4.9__g77_format_9995.8__g77_cilist_5.10__g77_cilist_6.11__g77_cilist_7.12__g77_cilist_8.13__g77_cilist_9.15__g77_format_9994.14.LC2dvout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfe R Ÿ ÑÝ å í ö !.!3" Í Û ÷!!Z!b" ‰ ‘ –"Ú   1!R!Š!’"è  . O!k!ª!²" ; I e!†!º!Â" F T p!‘!Ê!Ò"' T b ~!Ÿ!Ú!â"> k y •!¶!ê!ò"F l     !¼ !ð !ø "  4H\p„˜¬Àdmout.o/ 1189291774 1000 1000 100644 8700 ` ELF|4( U‰åWVSì‹U ‹MèüÿÿÿËu‹E‰UŒ‹U$‰M„‹}‰µhÿÿÿƒúP‰E‹‰}ˆ‰U€‰…|ÿÿÿ‰•pÿÿÿ~ ¹P‰pÿÿÿu˜‰µ,ÿÿÿ‹µpÿÿÿNxDÇE”»ë‰E”‰|$¹‹•,ÿÿÿ‰L$ ‹M”¸‰D$D ÿ‰$èüÿÿÿ‹E”@NyË‹µpÿÿÿF‰÷‰u”÷׉þƒÆQx7»‰|$¹‹•,ÿÿÿ‰L$ ‹M”¸‰D$D ÿ‰$èüÿÿÿÿE”NyÏ‹}ƒ‹»‰‹‰$èüÿÿÿ‰½ ÿÿÿ‹U€‹u ‰<$‰T$‰t$èüÿÿÿ‹pÿÿÿ‹• ÿÿÿ‹…,ÿÿÿ‰L$‰$‰D$èüÿÿÿèüÿÿÿ‹uŒ‹>…ÿŽ{‹uˆ‹…ÉŽn‹U„‹…ÀŽa‹}‹…À‰Âu¸…ÒˆOƒøKq ºgfff‰ð÷ê‰÷Áÿ¾‰µTþÿÿÁú)úJ‰•Xþÿÿˆô»´‰½$ÿÿÿ‰Pþÿÿ‹…TþÿÿƒÀ 9Á~‰…Pþÿÿ‹}‹‰ƒ¸‹•$ÿÿÿ‰$èüÿÿÿ‹Tþÿÿ‹µPþÿÿ‰M”)Îxk“‹‰•Lþÿÿ}”‰Hþÿÿ´&¼'‹•Hþÿÿ¹‹…Lþÿÿ‰L$‰$‰D$èüÿÿÿ‰|$‹… ÿÿÿ¹‰L$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}Œ‹7ÇE”N‰µDþÿÿˆE”‹µTþÿÿ‹•Tþÿÿ‰…@þÿÿ‹½Pþÿÿ‹È‰ÿÿÿ‹…|ÿÿÿ õøÿÿÿ)ׯȋ•|ÿÿÿ‰½XÿÿÿÁâ‰ìþÿÿ‰•Ìþÿÿ¶¿‹u‹‰ƒÌ‹ÿÿÿ‰ $èüÿÿÿ‹½@þÿÿº‹µ ÿÿÿ‰T$‰|$‰4$èüÿÿÿ‹½Xÿÿÿ…ÿxI‹µìþÿÿ‹•hÿÿÿÖ´&¼'‹M”¸‰D$‹… ÿÿÿTÎø‰T$‰$èüÿÿÿ‹ÌþÿÿÎOyÓèüÿÿÿÿE”ÿDþÿÿ‰_ÿÿÿƒ…Tþÿÿ ÿXþÿÿx ‹uˆ‹éþÿÿ‹U»T‹2‰³X‰<$èüÿÿÿèüÿÿÿÄ[^_]Ãø‰ÈƒÀˆ Áø¿H‰½8þÿÿ‰…<þÿÿx¬³Ü‰µ(ÿÿÿ‰4þÿÿ‹…8þÿÿƒÀ9Á~‰…4þÿÿ‹u‹>‰»à‹…(ÿÿÿ‰$èüÿÿÿ‹8þÿÿ‹µ4þÿÿ‰M”)Îx]‹“‰0þÿÿ}”‰•,þÿÿ‹,þÿÿº‹…0þÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹… ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹uŒ‹>ÇE”O‰½(þÿÿˆç}”‹4þÿÿ‹µ8þÿÿ‰½$þÿÿ‹•8þÿÿƒð‰…0ÿÿÿ‹½|ÿÿÿ)ñ‰TÿÿÿÕøÿÿÿ¯Ç‹|ÿÿÿÁቅðþÿÿ‰Ðþÿÿ‹U¾‹:‰»ô‹…0ÿÿÿ‰$èüÿÿÿ‰t$‹$þÿÿ‹• ÿÿÿ‰L$‰$èüÿÿÿ‹½Tÿÿÿ…ÿx;‹µðþÿÿ‹hÿÿÿκ‹E”‰T$‹• ÿÿÿLÆø‰L$‰$èüÿÿÿ‹…ÐþÿÿÆOyÓèüÿÿÿÿE”ÿ(þÿÿ‰mÿÿÿƒ…8þÿÿÿ<þÿÿˆæýÿÿ‹Uˆ‹ é<þÿÿ‰Ð÷؃øyºgfff‰ø÷ê‰øÁø¾‰µxÿÿÿÑú)ÂJ‰•¸þÿÿˆ¢ýÿÿ³‰µ8ÿÿÿ‰tÿÿÿ‹…xÿÿÿƒÀ9Á~‰…tÿÿÿ‹u‹‰ƒ‹•8ÿÿÿ‰$èüÿÿÿ‹xÿÿÿ‹µtÿÿÿ‰M”)Îx]»‹‰½ÿÿÿ}”‰ÿÿÿ‹•ÿÿÿ¸‹ÿÿÿ‰D$‰T$‰ $èüÿÿÿ‰|$‹• ÿÿÿ¸‰D$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}Œ‹7ÇE”N‰µ´þÿÿˆíE”‹µxÿÿÿ‹xÿÿÿ‰…°þÿÿ‹½tÿÿÿ“(‰•@ÿÿÿ‹…|ÿÿÿõøÿÿÿ)ϯЋ|ÿÿÿ‰½lÿÿÿÁቕÜþÿÿ‰¼þÿÿ‹u‹‰ƒ,‹•@ÿÿÿ‰$èüÿÿÿ‹½°þÿÿ¹‹µ ÿÿÿ‰L$‰|$‰4$èüÿÿÿ‹½lÿÿÿ…ÿxA‹µÜþÿÿ‹hÿÿÿζ‹U”¸‰D$‹… ÿÿÿLÖø‰L$‰$èüÿÿÿ‹•¼þÿÿÖOyÓèüÿÿÿÿE”ÿ´þÿÿ‰gÿÿÿƒ…xÿÿÿÿ¸þÿÿˆÖûÿÿ‹}ˆ‹é6þÿÿƒø qº«ªª*‰ð÷ê‰÷Áÿ¾‰µþÿÿ)úJ‰• þÿÿˆ˜ûÿÿ»‰½Dÿÿÿ‰þÿÿ‹…þÿÿƒÀ9Á~‰…þÿÿ‹}‹‰ƒ‹•Dÿÿÿ‰$èüÿÿÿ‹þÿÿ‹µþÿÿ‰M”)Îx]“‹‰•þÿÿ}”‰þÿÿ‹•þÿÿ¹‹…þÿÿ‰L$‰$‰D$èüÿÿÿ‰|$‹… ÿÿÿ¹‰L$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}Œ‹7ÇE”N‰µ þÿÿˆóM”‹µþÿÿ‹•þÿÿ‰þÿÿ‹½þÿÿƒ‰…ÿÿÿ‹|ÿÿÿõøÿÿÿ)ׯÁ‹•|ÿÿÿ‰½PÿÿÿÁ≅ôþÿÿ‰•Ôþÿÿ‹u‹‰‹‹…ÿÿÿ‰$èüÿÿÿ‹½þÿÿº‹µ ÿÿÿ‰T$‰|$‰4$èüÿÿÿ‹½Pÿÿÿ…ÿxG‹µôþÿÿ‹•hÿÿÿÖ¶¿¹‹E”‰L$‹ ÿÿÿTÆø‰T$‰ $èüÿÿÿ‹…ÔþÿÿÆOyÓèüÿÿÿÿE”ÿ þÿÿ‰aÿÿÿƒ…þÿÿÿ þÿÿˆÆùÿÿ‹uˆ‹é0þÿÿqºgfff‰ð÷ê‰ðÁø¿‰½þÿÿÑú)ÂJ‰•þÿÿˆùÿÿ»,‰½ ÿÿÿ‰üýÿÿ‹…þÿÿƒÀ9Á~‰…üýÿÿ‹}‹‰ƒ0‹• ÿÿÿ‰$èüÿÿÿ‹þÿÿ‹µüýÿÿ‰M”)Îx]“‹‰•øýÿÿ}”‰ôýÿÿ‹•ôýÿÿ¹‹…øýÿÿ‰L$‰$‰D$èüÿÿÿ‰|$‹… ÿÿÿ¹‰L$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}Œ‹7ÇE”N‰µðýÿÿˆêM”‹µþÿÿ‹•þÿÿ‰ìýÿÿ‹½üýÿÿƒ@‰…ÿÿÿ‹|ÿÿÿõøÿÿÿ)ׯÁ‹•|ÿÿÿ‰½LÿÿÿÁ≅øþÿÿ‰•Øþÿÿ‹u‹‰‹D‹…ÿÿÿ‰$èüÿÿÿ‹½ìýÿÿº‹µ ÿÿÿ‰T$‰|$‰4$èüÿÿÿ‹½Lÿÿÿ…ÿx>‹µøþÿÿ‹•hÿÿÿÖv¹‹E”‰L$‹ ÿÿÿTÆø‰T$‰ $èüÿÿÿ‹…ØþÿÿÆOyÓèüÿÿÿÿE”ÿðýÿÿ‰jÿÿÿƒ…þÿÿÿþÿÿˆÆ÷ÿÿ‹uˆ‹é9þÿÿƒø÷‰ÈƒÀyAÁø¿H‰½¨þÿÿ‰…¬þÿÿˆŽ÷ÿÿ³<‰µHÿÿÿ‰¤þÿÿ‹…¨þÿÿƒÀ9Á~‰…¤þÿÿ‹u‹>‰»@‹…Hÿÿÿ‰$èüÿÿÿ‹¨þÿÿ‹µ¤þÿÿ‰M”)Îx]‹“‰ þÿÿ}”‰•œþÿÿ‹œþÿÿº‹… þÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹… ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹uŒ‹>ÇE”O‰½˜þÿÿˆé}”‹¤þÿÿ‹µ¨þÿÿ‰½”þÿÿ‹•¨þÿÿƒP‰…4ÿÿÿ‹½|ÿÿÿ)ñ‰dÿÿÿÕøÿÿÿ¯Ç‹|ÿÿÿÁቅàþÿÿ‰Àþÿÿ‹U¾‹:‰»T‹…4ÿÿÿ‰$èüÿÿÿ‰t$‹”þÿÿ‹• ÿÿÿ‰L$‰$èüÿÿÿ‹½dÿÿÿ…ÿx=‹µàþÿÿ‹hÿÿÿÎfº‹E”‰T$‹• ÿÿÿLÆø‰L$‰$èüÿÿÿ‹…ÀþÿÿÆOyÓèüÿÿÿÿE”ÿ˜þÿÿ‰kÿÿÿƒ…¨þÿÿÿ¬þÿÿˆÆõÿÿ‹Uˆ‹ é:þÿÿƒø ýqºVUUU‰ð÷ê‰÷Áÿ¾‰µŒþÿÿ)úJ‰•þÿÿˆˆõÿÿ»d‰½<ÿÿÿ‹…Œþÿÿ‰ÏƒÀ9Á~‰Ç‹u‹‰þ‰ƒh‹•<ÿÿÿ‰$èüÿÿÿ‹Œþÿÿ)ΉM”xiƒ“‰…ˆþÿÿM”‰•„þÿÿ‰€þÿÿ‹•ˆþÿÿ¸‹„þÿÿ‰D$‰T$‰ $èüÿÿÿ‹•€þÿÿ¸‹ ÿÿÿ‰D$‰T$‰ $èüÿÿÿÿE”Ny¸èüÿÿÿ‹MŒ‹1ÇE”N‰µ|þÿÿˆáU”‹Œþÿÿ‹µŒþÿÿ‰•xþÿÿ‹•|ÿÿÿƒx‰…üþÿÿ)Ïõøÿÿÿ‰½`ÿÿÿ¯Â‹½|ÿÿÿ‰…äþÿÿÁ牽Äþÿÿ‹U‹:‰»|‹…üþÿÿ‰$èüÿÿÿ‹½ ÿÿÿ¹‹µxþÿÿ‰L$‰<$‰t$èüÿÿÿ‹½`ÿÿÿ…ÿx;‹µäþÿÿ‹hÿÿÿκ‹E”‰T$‹• ÿÿÿLÆø‰L$‰$èüÿÿÿ‹…ÄþÿÿÆOyÓèüÿÿÿÿE”ÿ|þÿÿ‰mÿÿÿƒ…ŒþÿÿÿþÿÿˆÈóÿÿ‹uˆ‹éBþÿÿAéóóÿÿq¿‰ð‰½pþÿÿÁèÆÑþN‰µtþÿÿˆ’óÿÿ“Œ‰•ÿÿÿ‹…pþÿÿ‰Ï@9Á~‰Ç‹U‹2‰³‹…ÿÿÿ‰þ‰$èüÿÿÿ‹pþÿÿ)ΉM”xi“ƒ‰•lþÿÿM”‰…hþÿÿ‰dþÿÿ‹hþÿÿº‹…lþÿÿ‰T$‰ $‰D$èüÿÿÿ‹…dþÿÿº‹ ÿÿÿ‰T$‰D$‰ $èüÿÿÿÿE”Ny¸èüÿÿÿ‹MŒ‹1ÇE”N‰µ`þÿÿˆáU”‹pþÿÿ‹µpþÿÿ‰•\þÿÿ‹•|ÿÿÿƒ ‰…ÿÿÿ)Ïõøÿÿÿ‰½\ÿÿÿ¯Â‹½|ÿÿÿ‰…èþÿÿÁ牽Èþÿÿ‹U‹:‰»¤‹…ÿÿÿ‰$èüÿÿÿ‹½ ÿÿÿ¹‹µ\þÿÿ‰L$‰<$‰t$èüÿÿÿ‹½\ÿÿÿ…ÿx;‹µèþÿÿ‹hÿÿÿκ‹E”‰T$‹• ÿÿÿLÆø‰L$‰$èüÿÿÿ‹…ÈþÿÿÆOyÓèüÿÿÿÿE”ÿ`þÿÿ‰mÿÿÿƒ…pþÿÿÿtþÿÿˆÔñÿÿ‹uˆ‹éDþÿÿCol(/,1X,A,/,1X,A)(10X,10(4X,3A1,I4,1X))(10X,8(5X,3A1,I4,2X))(10X,6(7X,3A1,I4,4X))(10X,5(9X,3A1,I4,6X))(1X, Row,I4,:,1X,1P,10D12.3)(1X, Row,I4,:,1X,1P,8D14.5)(1X, Row,I4,:,1X,1P,6D18.9)(1X, Row,I4,:,1X,1P,5D22.13)(1X, )€( =ÀRà€( =ÀRà- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ d %@ +H4Hh0 l! D°L´Y¼€ÀÀ#ã™Ô* äñÿ !5FZ(k€ <(¤P¶ ÊdÜ=ñxÀŒ*R? Qà f´xÈ‹Üžð±Ä×,ê@ýT  %* /6 Mcjqxdmout.ficol.0__g77_cilist_0.2__g77_format_9999.1__g77_cilist_1.4__g77_format_9998.3__g77_cilist_2.6__g77_format_9994.5__g77_cilist_3.8__g77_format_9997.7__g77_cilist_4.10__g77_format_9993.9__g77_cilist_5.12__g77_format_9996.11__g77_cilist_6.14__g77_format_9992.13__g77_cilist_7.16__g77_format_9995.15__g77_cilist_8.18__g77_format_9991.17__g77_cilist_9.19__g77_cilist_10.20__g77_cilist_11.21__g77_cilist_12.22__g77_cilist_13.23__g77_cilist_14.24__g77_cilist_15.25__g77_cilist_16.26__g77_cilist_17.28__g77_format_9990.27.LC2.LC3dmout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfe+ ,w #§-É #ô-   ' .5/W/\0Ø  .) / (m/ˆ/“0Í  %.F/Ž/ž0Ï × ß.ä0  J X.q w (§/Â/Í0 J X.t/®/¾0* T b.{ ( ±/Ì/×0 O ].~/¾/Î04 ^ l.… ‹ (»/Ö/á0 Y g .ˆ /Î /Þ 0= g u .Ž ” (Ä /ß /ê 0$ b p .‘ /Î /Þ 0> h v . • (Å /à /ë 0% h v .’ /Î /Þ 0D h v.‰  (Å/æ/ñ0+ c q.’/Ì/Ü0: Z j.} ƒ (¹/Ú/å0 W e.†/À/Ð0  4H\p„˜¬ÀÔèü$8L`cvout.o/ 1189291774 1000 1000 100644 10724 ` ELFT4( U‰åWVSì|‹U‹uèüÿÿÿËM ‹EƒúP‰uŒ‰Mˆ‰…|ÿÿÿ‰U„‰U€~ÇE€P‹u€E˜‰…ÿÿÿNx8»‰½$ÿÿÿ‰Çf‰<$‹•$ÿÿÿ¹‰L$ ¸G‰D$‰T$èüÿÿÿNyØ‹}€G‰þ‰½ÿÿÿ÷Ö‰÷ƒÇQxQ‹•ÿÿÿ‹‹…ÿÿÿ‰ ÿÿÿtÿ´&‰4$‹… ÿÿÿ¹‰L$ ºF‰T$‰D$èüÿÿÿÿ…ÿÿÿOyÒ‹UŒƒ‹ ‰‹‰$èüÿÿÿ‹u„‹‹}‰ÿÿÿ‰ $‰t$‰|$èüÿÿÿ‹U€‹µÿÿÿ‹…ÿÿÿ‰T$‰4$‰D$èüÿÿÿèüÿÿÿ‹}ˆ‹7…öŽ¯‹}‹…À‰Âu¸…Òˆ ƒø™‰ðƒÀˆ6 ÇE”ÁøH‰…ÈþÿÿˆN“ }”‰•tÿÿÿE‰½8ÿÿÿ‹´‰…(ÿÿÿ“ȉpÿÿÿ»Ü‰•lÿÿÿ‰½hÿÿÿë6‰È)ðƒøþ„€ƒøÿ„'ƒøþ„ÎÿÈþÿÿy‰}”ˆÙ‹Mˆ‹1‹M”‰ðQ9Ö~‰Ð‰E9òµ‹UŒ‹ ‰‹¤‹½tÿÿÿ‰<$èüÿÿÿ‹µ8ÿÿÿ¸‹ÿÿÿ‰D$‰t$‰ $èüÿÿÿ‹½(ÿÿÿº‹…ÿÿÿ‰T$‰|$‰$èüÿÿÿ‹u‹U”‰÷)×x>‹…|ÿÿÿ³‰µÄþÿÿtÐø´&‰t$‹Äþÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹M”ÿÈþÿÿy‰}”‰'ÿÿÿ‹MŒƒ‹1‰³”‰$èüÿÿÿèüÿÿÿÄ|[^_]Ãø9ÇE”N¿VUUU‰È÷ï‰ÈÁø)ÂJ‰•´þÿÿx«“ðE”‰•dÿÿÿ}‰…<ÿÿÿ‹‰½,ÿÿÿ“‰`ÿÿÿ‰•\ÿÿÿë*‰×)÷G„+9Ö„Óÿ´þÿÿz‰}”ˆNÿÿÿ‹Mˆ‹1‹U”‰ñB9Æ~‰Á‰M9ðÁ‹UŒ¿‹ ‰‹ô‹…dÿÿÿ‰$èüÿÿÿ‰|$‹µ<ÿÿÿ‹ÿÿÿ‰t$‰ $èüÿÿÿ‹½ÿÿÿº‹…,ÿÿÿ‰T$‰<$‰D$èüÿÿÿ‹u‹U”‰÷)×xC‹…|ÿÿÿ³‰µ°þÿÿtÐø¶¿‰t$‹°þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”éÿÿÿ‹UŒ¿‹ ‰‹¸‹µpÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…8ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ(ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈øýÿÿ‹…|ÿÿÿ³‰µÀþÿÿtÐø‰t$‹Àþÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹M”é»ýÿÿ‹UŒ¿‹ ‰‹Ì‹µlÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…8ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ(ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈Hýÿÿ‹…|ÿÿÿ³‰µ¼þÿÿtÐø‰t$‹¼þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹M”é ýÿÿ‹UŒ¿‹ ‰‹à‹µhÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…8ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ(ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈˜üÿÿ‹…|ÿÿÿ³‰µ¸þÿÿtÐø‰t$‹¸þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹M”é[üÿÿ‰Ð÷؃øƒÇE”F‰ÁÁéÈÑøH‰…üþÿÿˆ@üÿÿ}”U‰½ ÿÿÿ‰•ÿÿÿ‰u‹U”B9Æ~‰E9Ö„Ë‹EŒ“‹8‰»¿‰$èüÿÿÿ‹µ ÿÿÿ¹‹…ÿÿÿ‰L$‰t$‰$èüÿÿÿ‰|$‹•ÿÿÿ‹ÿÿÿ‰T$‰ $èüÿÿÿ‹u‹U”‰÷)×xE‹|ÿÿÿ³‰µÿÿÿtÑø´&¼'‰t$‹•ÿÿÿ¸‰D$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿüþÿÿˆUûÿÿ‹Eˆ‹0éÿÿÿ‹UŒ³(¿‹‰ƒ,‰4$èüÿÿÿ‰|$‹ ÿÿÿ‹…ÿÿÿ‰L$‰$èüÿÿÿ‹½ÿÿÿº‹µÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)׈vÿÿÿ‹|ÿÿÿ³‰µøþÿÿtÑøë ‰t$‹…øþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßé+ÿÿÿƒøÑÇE”N¿VUUU‰È÷ï‰ÈÁø)ÂJ‰•¤þÿÿˆeúÿÿ“,E”‰•Xÿÿÿ}‰…@ÿÿÿ‹@‰½0ÿÿÿ“T‰Tÿÿÿ‰•Pÿÿÿë*‰×)÷G„¥9Ö„óÿ¤þÿÿz‰}”ˆúÿÿ‹Mˆ‹1‹U”‰ñB9Æ~‰Á‰M9ðÁ‹UŒ¿‹ ‰‹0‹…Xÿÿÿ‰$èüÿÿÿ‰|$‹µ@ÿÿÿ‹ÿÿÿ‰t$‰ $èüÿÿÿ‹½ÿÿÿº‹…0ÿÿÿ‰T$‰<$‰D$èüÿÿÿ‹u‹U”‰÷)×x=‹…|ÿÿÿ³‰µ þÿÿtÐø¶‰t$‹ þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”é#ÿÿÿ‹UŒ¾‹:‰»‹`ÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿ‹…<ÿÿÿ‰<$‰D$èüÿÿÿ‹,ÿÿÿº‹µÿÿÿ‰T$‰L$‰4$èüÿÿÿ‹E‹U”‰Ç)׈Húÿÿ‹…|ÿÿÿ³‰µ¬þÿÿtÐø‰t$‹¬þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”é-ùÿÿ‹UŒ¿‹ ‰‹‹µ\ÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…<ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ,ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈˜ùÿÿ‹…|ÿÿÿ³‰µ¨þÿÿtÐø‰t$‹¨þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”é}øÿÿƒøŽTƒø½ÇE”~‰ùÁéÏÑÿO‰½àþÿÿˆ«÷ÿÿU”E‰•Üþÿÿ‰…Øþÿÿ‹M”‰òA9Æ~‰Â‰U9΄ˋUŒƒd‹:‰»h‰$èüÿÿÿ‹µÜþÿÿ¹‹½ÿÿÿ‰L$‰t$‰<$èüÿÿÿ‹…Øþÿÿº‹ÿÿÿ‰T$‰D$‰ $èüÿÿÿ‹u‹U”‰÷)×x?‹|ÿÿÿ³‰µÔþÿÿtÑø´&‰t$‹…Ôþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿàþÿÿˆÅöÿÿ‹}ˆ‹7é"ÿÿÿÇE”F‰ÁÁéÈÑøH‰…”þÿÿˆ›öÿÿ‹hE”‰Lÿÿÿ}‰…Dÿÿÿ“|‰½4ÿÿÿ‰•Hÿÿÿë"‰×)÷G„Žÿ”þÿÿz‰}”ˆRöÿÿ‹Uˆ‹2‹U”‰ñB9Æ~‰Á‰Mz9÷Æ‹UŒ‹:‰»l‹Lÿÿÿ‰ $èüÿÿÿ‹µDÿÿÿ¸‹½ÿÿÿ‰D$‰t$‰<$èüÿÿÿ‹4ÿÿÿº‹…ÿÿÿ‰T$‰L$‰$èüÿÿÿ‹u‹U”‰÷)×xD‹…|ÿÿÿ³‰µþÿÿtÐø¶¼'‰t$‹þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”éÿÿÿ‹UŒ¾‹:‰»D‹Tÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿ‹…@ÿÿÿ‰<$‰D$èüÿÿÿ‹0ÿÿÿº‹µÿÿÿ‰T$‰L$‰4$èüÿÿÿ‹E‹U”‰Ç)׈Èûÿÿ‹…|ÿÿÿ³‰µœþÿÿtÐø‰t$‹œþÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßéŒûÿÿ‹UŒ¾‹:‰»€‹Hÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿ‹…Dÿÿÿ‰<$‰D$èüÿÿÿ‹4ÿÿÿº‹µÿÿÿ‰T$‰L$‰4$èüÿÿÿ‹E‹U”‰Ç)׈áþÿÿ‹…|ÿÿÿ³‰µŒþÿÿtÐø‰t$‹Œþÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßé¥þÿÿFéÂòÿÿ‹UŒ¿‹ ‰‹X‹µPÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…@ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ0ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈rúÿÿ‹…|ÿÿÿ³‰µ˜þÿÿtÐø‰t$‹˜þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßé6úÿÿÇE”~‰ùÁéÏÑÿO‰½ôþÿÿˆ`óÿÿU”E‰•ðþÿÿ‰…ìþÿÿ‹M”‰òA9Æ~‰Â‰U9΄ʋUŒƒ<‹:‰»@‰$èüÿÿÿ‹µðþÿÿ¹‹½ÿÿÿ‰L$‰t$‰<$èüÿÿÿ‹…ìþÿÿº‹ÿÿÿ‰T$‰D$‰ $èüÿÿÿ‹u‹U”‰÷)×xD‹|ÿÿÿ³‰µèþÿÿtÑø¶¼'‰t$‹…èþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿôþÿÿˆuòÿÿ‹}ˆ‹7éÿÿÿ‹UŒ³P¿‹‰ƒT‰4$èüÿÿÿ‰|$‹ðþÿÿ‹•ÿÿÿ‰L$‰$èüÿÿÿ‹½ÿÿÿ¸‹µìþÿÿ‰D$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)׈vÿÿÿ‹|ÿÿÿ³‰µäþÿÿtÑøë ‰t$‹…äþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßé+ÿÿÿ‹UŒ³x¿‹‰ƒ|‰4$èüÿÿÿ‰|$‹Üþÿÿ‹•ÿÿÿ‰L$‰$èüÿÿÿ‹½ÿÿÿ¸‹µØþÿÿ‰D$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)׈púÿÿ‹|ÿÿÿ³‰µÐþÿÿtÑø‰t$‹…Ðþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßé4úÿÿÇE”Nˆñÿÿƒ‹•|ÿÿÿ‹Œ‰…Ìþÿÿ‹…ÿÿÿ}”‰ÿÿÿLÂø‰½ÿÿÿ‰xÿÿÿ‹EŒ‹‰‹‹•ÿÿÿ‰$èüÿÿÿ‰|$‹ÿÿÿ¸‰D$¿‰ $èüÿÿÿ‰|$‹•ÿÿÿ‹½ÿÿÿ‰$‰|$èüÿÿÿ‹xÿÿÿ¸‹•Ìþÿÿ‰D$‰L$‰$èüÿÿÿèüÿÿÿÿE”N‰{ÿÿÿé?ðÿÿ(/,1X,A,/,1X,A)(1X,I4, - ,I4,:,1X,1P,2((,E10.3,,,E10.3,) ))(1X,I4, - ,I4,:,1X,1P,1((,E10.3,,,E10.3,) ))(1X,I4, - ,I4,:,1X,1P,2((,E12.5,,,E12.5,) ))(1X,I4, - ,I4,:,1X,1P,1((,E12.5,,,E12.5,) ))(1X,I4, - ,I4,:,1X,1P,2((,E14.7,,,E14.7,) ))(1X,I4, - ,I4,:,1X,1P,1((,E14.7,,,E14.7,) ))(1X,I4, - ,I4,:,1X,1P,1((,E20.13,,,E20.13,) ))(1X,I4, - ,I4,:,1X,1P,4((,E10.3,,,E10.3,) ))(1X,I4, - ,I4,:,1X,1P,3((,E10.3,,,E10.3,) ))(1X,I4, - ,I4,:,1X,1P,2((,E10.3,,,E10.3,) ))(1X,I4, - ,I4,:,1X,1P,1((,E10.3,,,E10.3,) ))(1X,I4, - ,I4,:,1X,1P,3((,E12.5,,,E12.5,) ))(1X,I4, - ,I4,:,1X,1P,2((,E12.5,,,E12.5,) ))(1X,I4, - ,I4,:,1X,1P,1((,E12.5,,,E12.5,) ))(1X,I4, - ,I4,:,1X,1P,3((,E14.7,,,E14.7,) ))(1X,I4, - ,I4,:,1X,1P,2((,E14.7,,,E14.7,) ))(1X,I4, - ,I4,:,1X,1P,1((,E14.7,,,E14.7,) ))(1X,I4, - ,I4,:,1X,1P,2((,E20.13,,,E20.13,) ))(1X,I4, - ,I4,:,1X,1P,1((,E20.13,,,E20.13,) ))(1X, ) ` à ` à ` à ` à ` Ù- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@¬ $$ %á +ä4ä¤0 <)¨ DˆLŒY”€˜˜#»™¬à7 Œ —ñÿ .? 7S(d`7x<‰ 7P®à7ÂdÔ 7éxû`7Œ" 97 Ià7^´p 7…Ș`7­ÜÀ 7Õðèà7ý 7%8`7M,` 7u@ˆà7T° 7ÅhØ`9í| 9(Ù  =B G¬N e{‚‰cvout.f__g77_cilist_0.1__g77_format_9999.0__g77_cilist_1.3__g77_format_9998.2__g77_cilist_2.5__g77_format_9997.4__g77_cilist_3.7__g77_format_9988.6__g77_cilist_4.9__g77_format_9987.8__g77_cilist_5.11__g77_format_9978.10__g77_cilist_6.13__g77_format_9977.12__g77_cilist_7.15__g77_format_9968.14__g77_cilist_8.17__g77_format_9958.16__g77_cilist_9.19__g77_format_9957.18__g77_cilist_10.21__g77_format_9956.20__g77_cilist_11.23__g77_format_9955.22__g77_cilist_12.25__g77_format_9948.24__g77_cilist_13.27__g77_format_9947.26__g77_cilist_14.29__g77_format_9946.28__g77_cilist_15.31__g77_format_9938.30__g77_cilist_16.33__g77_format_9937.32__g77_cilist_17.35__g77_format_9936.34__g77_cilist_18.37__g77_format_9928.36__g77_cilist_19.39__g77_format_9927.38__g77_cilist_20.41__g77_format_9994.40.LC2.LC3cvout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfe8 9R 0:¥ 0á:ó û ;  4%<D<I=Ÿ · Ã Ï 3 A;b<ƒ<› 5Ê<Ò=ð ø ;=B Z f à Ñ;í<<& 5Z<b=z ˆ;¤<Å<á 5 <=* 8;T<u<‘ 5º<Â=Ú è;<%<A 5j<r=Ú â ï;<,<D 5z<‚=¥ ² º;Ö<÷< 5J<ˆ   ¬   ;3 <T <l 5š <¢ =º È ;ä < <! 5J <R =j x ;” <µ <Ñ 5ú < =p x € ;¡ < <Ú 5 < =R j ½ Ë ;ì < <% 5Z <b =z ˆ ;¤ <Å <á 5 <! /;K<l<ˆ 5°<Ð Þ;ú<<7 5_<» à Ë;ì< <% 5Z<b=… ’ š;¶<×<ó 5*<; H P;l<<© 5Ñ<í 5ù ) 7;W<s<”<™=  4H\p„˜¬ÀÔèü$8L`tˆœcmout.o/ 1189291774 1000 1000 100644 13644 ` ELF,"4( U‰åWVSìL‹u ‹UèüÿÿÿËM‹E‰uˆ‹u$‰U€‹}‰hÿÿÿƒþP‰EŒ‹‰}„‰µ|ÿÿÿ‰…xÿÿÿ‰µpÿÿÿ~ ºP‰•pÿÿÿ‹µpÿÿÿM˜‰ÿÿÿNxDÇE”»ë‰E”‰|$¹‹•ÿÿÿ‰L$ ‹M”¸‰D$D ÿ‰$èüÿÿÿ‹E”@NyË‹µpÿÿÿF‰÷‰u”÷׉þƒÆQx7»‰|$¹‹•ÿÿÿ‰L$ ‹M”¸‰D$D ÿ‰$èüÿÿÿÿE”NyÏ‹}Œƒ‹»‰‹‰$èüÿÿÿ‰½ÿÿÿ‹•|ÿÿÿ‹u ‰<$‰T$‰t$èüÿÿÿ‹pÿÿÿ‹•ÿÿÿ‹…ÿÿÿ‰L$‰$‰D$èüÿÿÿèüÿÿÿ‹uˆ‹>…ÿŽå‹u„‹…ÉŽØ‹U€‹…ÀŽË‹}‹…À‰Âu¸…Òˆ]ƒø½‰ÈƒÀˆÇEÁøH‰…<þÿÿˆj»ð‰½ÿÿÿ‰8þÿÿ‹EƒÀ9Á~‰…8þÿÿ‹UŒ‹:‰»ô‹ÿÿÿ‰ $èüÿÿÿ‹E‹µ8þÿÿ‰E”)Æxg‹ƒ‰4þÿÿ}”‰…0þÿÿv¼'‹•4þÿÿ¸‹0þÿÿ‰D$‰T$‰ $èüÿÿÿ‰|$‹•ÿÿÿ¸‰D$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µ,þÿÿˆÃ“‹M»‰•Pÿÿÿ‹•xÿÿÿ³,‰½Lÿÿÿƒ@‰µHÿÿÿÁ≅Dÿÿÿ‰•¸þÿÿ‰•¼þÿÿ‰•°þÿÿ‰•´þÿÿë+‰È)Ѓøþ„ý@„ 9Ê„HÿE”ÿ,þÿÿˆÃ‹u„A‹9ÐÉ‹MŒ}”‹1‰³‹…Pÿÿÿ‰$èüÿÿÿ‰|$‹ÿÿÿº‰T$‰ $èüÿÿÿ‹E‹½8þÿÿ)Çx\‹µxÿÿÿÅøÿÿÿ‹•hÿÿÿ‹¯Æ‰(þÿÿ4v¼'‹U”¸‰D$‹…(þÿÿLÖø‰L$‰$èüÿÿÿ‹•¼þÿÿÖOyÓèüÿÿÿ‹MÿE”ÿ,þÿÿ‰=ÿÿÿÿ<þÿÿy‰}ˆD‹u„‹éÜýÿÿ‹}Œu”‹‰ƒ‹•Lÿÿÿ‰$èüÿÿÿ‰t$‹½ÿÿÿ¹‰L$‰<$èüÿÿÿ‹E‹½8þÿÿ)Çx‰‹µxÿÿÿÅøÿÿÿ‹hÿÿÿ“¯Æ‰•$þÿÿ4´&‹M”¸‰D$‹…$þÿÿTÎø‰T$‰$èüÿÿÿ‹¸þÿÿÎOyÓèüÿÿÿ‹Mé+ÿÿÿ‹}Œu”‹‰ƒ0‹Hÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿº‰T$‰<$èüÿÿÿ‹E‹½8þÿÿ)LjÛþÿÿ‹µxÿÿÿ Åøÿÿÿ“‰• þÿÿ¯Î‹•hÿÿÿ4‰ö¼'¹‹E”‰L$‹ þÿÿTÆø‰T$‰ $èüÿÿÿ‹…´þÿÿÆOyÓèüÿÿÿ‹Mé{þÿÿ‹}Œu”‹‰‹D‹…Dÿÿÿ‰$èüÿÿÿ‰t$‹½ÿÿÿº‰T$‰<$èüÿÿÿ‹E‹½8þÿÿ)Lj+þÿÿ‹µxÿÿÿÅøÿÿÿ‹•hÿÿÿ‹¯Æ‰þÿÿ4‰ö¼'‹U”¸‰D$‹…þÿÿLÖø‰L$‰$èüÿÿÿ‹•°þÿÿÖOyÓèüÿÿÿ‹MéËýÿÿƒøÇEq¿VUUU‰ð÷ï‰ðÁø)ÂJ‰•øýÿÿ‰ñ ‹MŒ»0‹1‰³4‰<$èüÿÿÿèüÿÿÿÄL[^_]ËMéyýÿÿƒøšÇEq¿VUUU‰ð÷ï‰ðÁø)ÂJ‰•þÿÿx§“T‰•ÿÿÿ‰þÿÿ‹EƒÀ9Á~‰…þÿÿ‹UŒ‹‰ƒX‹½ÿÿÿ‰<$èüÿÿÿ‹M‹µþÿÿ‰M”)Îxd»‹‰½þÿÿ}”‰ þÿÿ´&‹ þÿÿº‹…þÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µþÿÿˆš‹…xÿÿÿ»h‹M‰½@ÿÿÿ³|Áà‰µ<ÿÿÿ“‰•8ÿÿÿ‰…Äþÿÿ‰…Èþÿÿ‰…Àþÿÿë"‰Ï)×G„ñ9Ê„“ÿE”ÿþÿÿˆ¾‹u„A‹9ÐÒ‹MŒ¿‹1‰³l‹…@ÿÿÿ‰$èüÿÿÿ‰|$‹ÿÿÿU”‰T$‰ $èüÿÿÿ‹E‹½þÿÿ)ÇxW‹µxÿÿÿÅøÿÿÿ‹•hÿÿÿ‹¯Æ‰þÿÿ4t&‹U”¸‰D$‹…þÿÿLÖø‰L$‰$èüÿÿÿ‹•ÈþÿÿÖOyÓèüÿÿÿ‹MÿE”ÿþÿÿ‰Bÿÿÿÿþÿÿy‰}ˆ¤ýÿÿ‹u„‹éÿýÿÿ‹uŒ‹>‰»€‹…<ÿÿÿ‰$èüÿÿÿ‹µÿÿÿºM”‰T$‰L$‰4$èüÿÿÿ‹E‹½þÿÿ)Çx‰‹•xÿÿÿÅøÿÿÿ‹hÿÿÿ³¯Â‰µþÿÿ4´&‹M”¸‰D$‹…þÿÿTÎø‰T$‰$èüÿÿÿ‹ÄþÿÿÎOyÓèüÿÿÿ‹Mé+ÿÿÿ‹}Œu”‹‰ƒ”‹8ÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿº‰T$‰<$èüÿÿÿ‹E‹½þÿÿ)LjÛþÿÿ‹µxÿÿÿ Åøÿÿÿ“‰•üýÿÿ¯Î‹•hÿÿÿ4‰ö¼'¹‹E”‰L$‹üýÿÿTÆø‰T$‰ $èüÿÿÿ‹…ÀþÿÿÆOyÓèüÿÿÿ‹Mé{þÿÿ‹Mé‚þÿÿ‰Ð÷؃ø ÇEq‰ðÁèÆÑþN‰µ”þÿÿˆ üÿÿ“‰•ìþÿÿ‰tÿÿÿ‹E@9Á~‰…tÿÿÿ‹UŒ‹‰ƒ‹µìþÿÿ‰4$èüÿÿÿ‹M‹µtÿÿÿ‰M”)Îxj»‹‰½üþÿÿ}”‰ðþÿÿ¶¼'‹üþÿÿº‹…ðþÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µþÿÿˆ‹xÿÿÿu”“(‰µŒþÿÿƒ<Áቕlÿÿÿ‰…dÿÿÿ‰˜þÿÿ‰œþÿÿv¼'‹M„‹}99„” ‹EŒ¾‹‰‹,‹½lÿÿÿ‰<$èüÿÿÿ‰t$‹•Œþÿÿ‹…ÿÿÿ‰T$‰$èüÿÿÿ‹E‹½tÿÿÿ)ÇxX‹µxÿÿÿ Åøÿÿÿ“‰•øþÿÿ¯Î‹•hÿÿÿ4¶¹‹E”‰L$‹øþÿÿTÆø‰T$‰ $èüÿÿÿ‹…œþÿÿÆOyÓèüÿÿÿÿE”ÿþÿÿ‰?ÿÿÿƒEÿ”þÿÿˆ)úÿÿ‹}„‹é þÿÿƒøŽƒø ÇEy‰þÁî÷ÑÿO‰½dþÿÿˆíùÿÿ“Œ‰•ÿÿÿ‰`þÿÿ‹E@9Á~‰…`þÿÿ‹UŒ‹2‰³‹½ÿÿÿ‰<$èüÿÿÿ‹M‹µ`þÿÿ‰M”)Îx]‹ƒ‰\þÿÿ}”‰…Xþÿÿ‹•\þÿÿ¸‹Xþÿÿ‰D$‰T$‰ $èüÿÿÿ‰|$‹•ÿÿÿ¸‰D$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹uˆ‹>ÇE”O‰½Tþÿÿˆ‹xÿÿÿ}”ƒ ‰½Pþÿÿ“´ÁቅXÿÿÿ‰•Tÿÿÿ‰¨þÿÿ‰¬þÿÿ‹M„‹u91„; ‹UŒ¿‹ ‰‹¤‹µXÿÿÿ‰4$èüÿÿÿ‰|$‹…Pþÿÿ‹•ÿÿÿ‰D$‰$èüÿÿÿ‹E‹½`þÿÿ)Çxa‹µxÿÿÿÅøÿÿÿ‹hÿÿÿ“¯Æ‰•Lþÿÿ4ë ‹M”¸‰D$‹…LþÿÿTÎø‰T$‰$èüÿÿÿ‹¬þÿÿÎOyÓèüÿÿÿÿE”ÿTþÿÿ‰6ÿÿÿƒEÿdþÿÿˆøÿÿ‹E„‹é.þÿÿÇEq‰òÁêÖÑþN‰µØýÿÿˆï÷ÿÿƒô‰…ôþÿÿ‰Ôýÿÿ‹E@9Á~‰…Ôýÿÿ‹UŒ‹‰ƒø‹µôþÿÿ‰4$èüÿÿÿ‹M‹µÔýÿÿ‰M”)Îx^»‹‰½Ìýÿÿ}”‰Ðýÿÿ‹Ìýÿÿº‹…Ðýÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µÈýÿÿˆ‹xÿÿÿu”“‰µÄýÿÿƒÁቕ(ÿÿÿ‰…$ÿÿÿ‰Øþÿÿ‰Üþÿÿv¼'‹M‹}„A;Ü‹EŒ¾‹‰‹ ‹½(ÿÿÿ‰<$èüÿÿÿ‰t$‹•Äýÿÿ‹…ÿÿÿ‰T$‰$èüÿÿÿ‹E‹½Ôýÿÿ)ÇxW‹µxÿÿÿ Åøÿÿÿ“‰•Àýÿÿ¯Î‹•hÿÿÿ4t&¹‹E”‰L$‹ÀýÿÿTÆø‰T$‰ $èüÿÿÿ‹…ÜþÿÿÆOyÓèüÿÿÿÿE”ÿÈýÿÿ‰?ÿÿÿƒEÿØýÿÿˆöÿÿ‹}„‹é,þÿÿ“¤‰• ÿÿÿ‰ôýÿÿ‹EƒÀ9Á~‰…ôýÿÿ‹UŒ‹‰ƒ¨‹½ ÿÿÿ‰<$èüÿÿÿ‹M‹µôýÿÿ‰M”)Îxl»‹‰½ðýÿÿ}”‰ìýÿÿë ‹ìýÿÿº‹…ðýÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µèýÿÿˆ2‹…xÿÿÿ»¸‹M‰½4ÿÿÿ³ÌÁà‰µ0ÿÿÿ“à‰•,ÿÿÿ‰…Ðþÿÿ‰…Ôþÿÿ‰…Ìþÿÿë"‰Ï)×G„ó9Ê„’ÿE”ÿèýÿÿˆ¾‹u„A‹9ÐÒ‹MŒ¿‹1‰³¼‹…4ÿÿÿ‰$èüÿÿÿ‰|$‹ÿÿÿU”‰T$‰ $èüÿÿÿ‹E‹½ôýÿÿ)ÇxW‹µxÿÿÿÅøÿÿÿ‹•hÿÿÿ‹¯Æ‰äýÿÿ4t&‹U”¸‰D$‹…äýÿÿLÖø‰L$‰$èüÿÿÿ‹•ÔþÿÿÖOyÓèüÿÿÿ‹MÿE”ÿèýÿÿ‰Bÿÿÿÿøýÿÿy‰}ˆôÿÿ‹u„‹é÷ýÿÿÇEy‰þÁî÷ÑÿO‰½„þÿÿˆÚóÿÿ“P‰• ÿÿÿ‰€þÿÿ‹E@9Á~‰…€þÿÿ‹UŒ‹2‰³T‹½ ÿÿÿ‰<$èüÿÿÿ‹M‹µ€þÿÿ‰M”)Îx]‹ƒ‰|þÿÿ}”‰…xþÿÿ‹•|þÿÿ¸‹xþÿÿ‰D$‰T$‰ $èüÿÿÿ‰|$‹•ÿÿÿ¸‰D$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹uˆ‹>ÇE”O‰½tþÿÿˆý‹xÿÿÿ}”ƒd‰½pþÿÿ“xÁቅ`ÿÿÿ‰•\ÿÿÿ‰ þÿÿ‰¤þÿÿ‹M„‹u91„*‹UŒ¿‹ ‰‹h‹µ`ÿÿÿ‰4$èüÿÿÿ‰|$‹…pþÿÿ‹•ÿÿÿ‰D$‰$èüÿÿÿ‹E‹½€þÿÿ)Çx^‹µxÿÿÿÅøÿÿÿ‹hÿÿÿ“¯Æ‰•lþÿÿ4¶¿‹M”¸‰D$‹…lþÿÿTÎø‰T$‰$èüÿÿÿ‹¤þÿÿÎOyÓèüÿÿÿÿE”ÿtþÿÿ‰9ÿÿÿƒEÿ„þÿÿˆ òÿÿ‹E„‹é1þÿÿ‹}Œ‹‰‹ ‹…$ÿÿÿ‰$èüÿÿÿ‹½ÿÿÿº‹µÄýÿÿ‰T$‰<$‰t$èüÿÿÿ‹E‹½Ôýÿÿ)Ljwûÿÿ‹µxÿÿÿÅøÿÿÿ‹•hÿÿÿ‹¯Æ‰¼ýÿÿ4t&‹U”¸‰D$‹…¼ýÿÿLÖø‰L$‰$èüÿÿÿ‹•ØþÿÿÖOyÓéûÿÿ‹}Œ‹‰‹@‹…dÿÿÿ‰$èüÿÿÿ‹½ÿÿÿº‹µŒþÿÿ‰T$‰<$‰t$èüÿÿÿ‹E‹½tÿÿÿ)LjÀöÿÿ‹µxÿÿÿÅøÿÿÿ‹•hÿÿÿ‹¯Æ‰ˆþÿÿ4´&¼'‹U”¸‰D$‹…ˆþÿÿLÖø‰L$‰$èüÿÿÿ‹•˜þÿÿÖOyÓé[öÿÿ‹}Œ‹‰ƒ|‹\ÿÿÿ‰ $èüÿÿÿ‹½ÿÿÿº‹µpþÿÿ‰T$‰<$‰t$èüÿÿÿ‹E‹½€þÿÿ)Lj0þÿÿ‹µxÿÿÿ Åøÿÿÿ“‰•hþÿÿ¯Î‹•hÿÿÿ4´&¼'¹‹E”‰L$‹hþÿÿTÆø‰T$‰ $èüÿÿÿ‹… þÿÿÆOyÓéËýÿÿ‹uŒ‹>‰»Ð‹…0ÿÿÿ‰$èüÿÿÿ‹µÿÿÿºM”‰T$‰L$‰4$èüÿÿÿ‹E‹½ôýÿÿ)Ljƒûÿÿ‹•xÿÿÿÅøÿÿÿ‹hÿÿÿ³¯Â‰µàýÿÿ4‹M”¸‰D$‹…àýÿÿTÎø‰T$‰$èüÿÿÿ‹ÐþÿÿÎOyÓèüÿÿÿ‹Mé,ûÿÿ‹}Œu”‹‰ƒä‹,ÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿº‰T$‰<$èüÿÿÿ‹E‹½ôýÿÿ)LjÜúÿÿ‹µxÿÿÿ Åøÿÿÿ“‰•Üýÿÿ¯Î‹•hÿÿÿ4¹‹E”‰L$‹ÜýÿÿTÆø‰T$‰ $èüÿÿÿ‹…ÌþÿÿÆOyÓèüÿÿÿ‹Mé…úÿÿ‹}Œ‹‰ƒ¸‹Tÿÿÿ‰ $èüÿÿÿ‹½ÿÿÿº‹µPþÿÿ‰T$‰<$‰t$èüÿÿÿ‹E‹½`þÿÿ)Lj"öÿÿ‹µxÿÿÿ Åøÿÿÿ“‰•Hþÿÿ¯Î‹•hÿÿÿ4¹‹E”‰L$‹HþÿÿTÆø‰T$‰ $èüÿÿÿ‹…¨þÿÿÆOyÓéËõÿÿ‹MéêùÿÿAéwéÿÿÇE‰ÏOˆèíÿÿƒ“‰…Dþÿÿ³È‰•@þÿÿM‰µÿÿÿE”‰ÿÿÿ“‰…èþÿÿ³Ü‰•äþÿÿ‰µàþÿÿ‹uŒ‹‰“Ì‹ÿÿÿ‰ $èüÿÿÿ‹•Dþÿÿ¸‹µ@þÿÿ‰D$‰T$‰4$èüÿÿÿ‹•ÿÿÿ¹‹…ÿÿÿ‰L$‰$‰D$èüÿÿÿèüÿÿÿ‹uˆ‹ÇE”‰Îëz‹UŒ‹ ‰‹à‹…àþÿÿ‰$èüÿÿÿ‹•èþÿÿ¹‹…ÿÿÿ‰L$‰T$‰$èüÿÿÿ¹‹•xÿÿÿ‹…hÿÿÿ‰L$‹MI¯ÊÈ‹E”LÂø‹…äþÿÿ‰L$‰$èüÿÿÿèüÿÿÿÿE”NyƒÿEO‰ ÿÿÿéžìÿÿCol(/,1X,A,/,1X,A)(11X,4(9X,3A1,I4,9X))(10X,4(11X,3A1,I4,11X))(10X,3(13X,3A1,I4,13X))(12X,2(18X,3A1,I4,18X))(1X, Row,I4,:,1X,1P,2((,E10.3,,,E10.3,) ))(1X, Row,I4,:,1X,1P,1((,E10.3,,,E10.3,) ))(1X, Row,I4,:,1X,1P,2((,E12.5,,,E12.5,) ))(1X, Row,I4,:,1X,1P,1((,E12.5,,,E12.5,) ))(1X, Row,I4,:,1X,1P,2((,E14.7,,,E14.7,) ))(1X, Row,I4,:,1X,1P,1((,E14.7,,,E14.7,) ))(1X, Row,I4,:,1X,1P,1((,E20.13,,,E20.13,)))(1X, )(1X, Row,I4,:,1X,1P,4((,E10.3,,,E10.3,) ))(1X, Row,I4,:,1X,1P,3((,E10.3,,,E10.3,) ))(1X, Row,I4,:,1X,1P,2((,E10.3,,,E10.3,) ))(1X, Row,I4,:,1X,1P,1((,E10.3,,,E10.3,) ))(1X, Row,I4,:,1X,1P,3((,E12.5,,,E12.5,) ))(1X, Row,I4,:,1X,1P,2((,E12.5,,,E12.5,) ))(1X, Row,I4,:,1X,1P,1((,E12.5,,,E12.5,) ))(1X, Row,I4,:,1X,1P,3((,E14.7,,,E14.7,) ))(1X, Row,I4,:,1X,1P,2((,E14.7,,,E14.7,) ))(1X, Row,I4,:,1X,1P,1((,E14.7,,,E14.7,) ))(1X, Row,I4,:,1X,1P,2((,E20.13,,,E20.13,) ))(1X, Row,I4,:,1X,1P,1((,E20.13,,,E20.13,) ))€À'@>€ÀU@€À'@€À>@€UÀ5- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@œ Ô- %à7 +4D0 d4è D\!L`! Yl!€p!p!#“!™„$ÀE D)ñÿ !5FZ(k€5<À5¤P¶'ÊdÜ5ñx@5Œ*>? Q€5f´xÀ5È UµÜÈ5Ýðð@5+€5@,SÀ5h@{5T£h¶@5Ë|Þ€5óÀ5¤.¸A5VÌi@5~à‘€5¦ô¹ÌÀ7áô7 05  16; @œG ^t{‚‰cmout.ficol.0__g77_cilist_0.2__g77_format_9999.1__g77_cilist_1.4__g77_format_9998.3__g77_cilist_2.6__g77_format_9994.5__g77_cilist_3.8__g77_format_9984.7__g77_cilist_4.10__g77_format_9997.9__g77_cilist_5.12__g77_format_9993.11__g77_cilist_6.14__g77_format_9983.13__g77_cilist_7.16__g77_format_9996.15__g77_cilist_8.18__g77_format_9992.17__g77_cilist_9.20__g77_format_9982.19__g77_cilist_10.22__g77_format_9995.21__g77_cilist_11.24__g77_format_9991.23__g77_cilist_12.25__g77_cilist_13.27__g77_format_9974.26__g77_cilist_14.29__g77_format_9964.28__g77_cilist_15.31__g77_format_9954.30__g77_cilist_16.33__g77_format_9944.32__g77_cilist_17.34__g77_cilist_18.36__g77_format_9973.35__g77_cilist_19.38__g77_format_9963.37__g77_cilist_20.40__g77_format_9953.39__g77_cilist_21.41__g77_cilist_22.43__g77_format_9972.42__g77_cilist_23.45__g77_format_9962.44__g77_cilist_24.47__g77_format_9952.46__g77_cilist_25.48__g77_cilist_26.50__g77_format_9971.49__g77_cilist_27.52__g77_format_9961.51__g77_cilist_28.54__g77_format_9990.53.LC2.LC3.LC4cmout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfeF Gz =ªHÌ =÷H  A I;J]JbKÒ ù I # B]JxJƒK¢ « ½ É 7 EI`J† C¾JÎK  I3JY CŽJžK´ ÂIÝJ C>JNKd rIJ· CîJþK? G OITK• ¼ ÊIà æ BJ8JCKh w † Þ ìIJ+ C^JnK§ µIÓJù C. J> KT b I} J¡ CÞ Jî K1 V d Iz B€ ½ JØ Jã K  Z h I„ J¤ CÞ Jî KO t ‚ I˜ ž BÎ Jé Jô K ( a o I‹ J± Cî Jþ KM r €I– Bœ ÍJèJóK ' k yI•Jµ CîJþK- T bIx ~ B½JØJãK  & ~ ŒI¥JË CþJKb ‡ •I« ± BáJüJK/ ; t ‚IžJÄ CþJKB PIqJ› CÎJé ÷IJB C~J™ §IÈJì C.JI WIuJŸ CÍJÝKó IJ@ CtJ„K— ¥IÆJê CJT Z Bf „ C § µIÖJ÷JüK %IFJ~JƒK  4H\p„˜¬ÀÔèü$8L`tˆœ°ÄØì(<zvout.o/ 1189291774 1000 1000 100644 10820 ` ELF´4( U‰åWVSì|‹U‹uèüÿÿÿËM ‹EƒúP‰uŒ‰Mˆ‰…|ÿÿÿ‰U„‰U€~ÇE€P‹u€E˜‰…ÿÿÿNx8»‰½$ÿÿÿ‰Çf‰<$‹•$ÿÿÿ¹‰L$ ¸G‰D$‰T$èüÿÿÿNyØ‹}€G‰þ‰½ÿÿÿ÷Ö‰÷ƒÇQxQ‹•ÿÿÿ‹‹…ÿÿÿ‰ ÿÿÿtÿ´&‰4$‹… ÿÿÿ¹‰L$ ºF‰T$‰D$èüÿÿÿÿ…ÿÿÿOyÒ‹UŒƒ‹ ‰‹‰$èüÿÿÿ‹u„‹‹}‰ÿÿÿ‰ $‰t$‰|$èüÿÿÿ‹U€‹µÿÿÿ‹…ÿÿÿ‰T$‰4$‰D$èüÿÿÿèüÿÿÿ‹}ˆ‹7…öŽ¯‹}‹…À‰Âu¸…Òˆ<ƒø™‰ðƒÀˆŒ ÇE”ÁøH‰…ÈþÿÿˆN“ }”‰•tÿÿÿE‰½8ÿÿÿ‹´‰…(ÿÿÿ“ȉpÿÿÿ»Ü‰•lÿÿÿ‰½hÿÿÿë6‰È)ðƒøþ„€ƒøÿ„7ƒøþ„îÿÈþÿÿy‰}”ˆÙ‹Mˆ‹1‹M”‰ðQ9Ö~‰Ð‰E9òµ‹UŒ‹ ‰‹¤‹½tÿÿÿ‰<$èüÿÿÿ‹µ8ÿÿÿ¸‹ÿÿÿ‰D$‰t$‰ $èüÿÿÿ‹½(ÿÿÿº‹…ÿÿÿ‰T$‰|$‰$èüÿÿÿ‹u‹U”‰÷)×x>‹…|ÿÿÿ³Á≵Äþÿÿtðt&‰t$‹Äþÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹M”ÿÈþÿÿy‰}”‰'ÿÿÿ‹MŒƒ‹1‰³”‰$èüÿÿÿèüÿÿÿÄ|[^_]ÃøiÇE”N¿VUUU‰È÷ï‰ÈÁø)ÂJ‰•´þÿÿx«“ðE”‰•dÿÿÿ}‰…<ÿÿÿ‹‰½,ÿÿÿ“‰`ÿÿÿ‰•\ÿÿÿë*‰×)÷G„[9Ö„ÿ´þÿÿz‰}”ˆNÿÿÿ‹Mˆ‹1‹U”‰ñB9Æ~‰Á‰M9ðÁ‹UŒ¿‹ ‰‹ô‹…dÿÿÿ‰$èüÿÿÿ‰|$‹µ<ÿÿÿ‹ÿÿÿ‰t$‰ $èüÿÿÿ‹½ÿÿÿº‹…,ÿÿÿ‰T$‰<$‰D$èüÿÿÿ‹u‹U”‰÷)×xC‹…|ÿÿÿ³Á≵°þÿÿtð‰ö¼'‰t$‹°þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”éÿÿÿ‹UŒ¿‹ ‰‹¸‹µpÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…8ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ(ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈øýÿÿ‹…|ÿÿÿ³Á≵Àþÿÿtð´&¼'‰t$‹Àþÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹M”é«ýÿÿ‹UŒ¿‹ ‰‹Ì‹µlÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…8ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ(ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈8ýÿÿ‹…|ÿÿÿ³Á≵¼þÿÿtð´&¼'‰t$‹¼þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹M”éëüÿÿ‹UŒ¿‹ ‰‹à‹µhÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…8ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ(ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈xüÿÿ‹…|ÿÿÿ³Á≵¸þÿÿtð´&¼'‰t$‹¸þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹M”é+üÿÿ‰Ð÷؃ø£ÇE”F‰ÁÁéÈÑøH‰…üþÿÿˆüÿÿ}”U‰½ ÿÿÿ‰•ÿÿÿ‰u‹U”B9Æ~‰E9Ö„Ë‹EŒ“‹8‰»¿‰$èüÿÿÿ‹µ ÿÿÿ¹‹…ÿÿÿ‰L$‰t$‰$èüÿÿÿ‰|$‹•ÿÿÿ‹ÿÿÿ‰T$‰ $èüÿÿÿ‹u‹U”‰÷)×xE‹|ÿÿÿ³Á≵ÿÿÿt ðt&¼'‰t$‹•ÿÿÿ¸‰D$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿüþÿÿˆ%ûÿÿ‹Eˆ‹0éÿÿÿ‹UŒ³(¿‹‰ƒ,‰4$èüÿÿÿ‰|$‹ ÿÿÿ‹…ÿÿÿ‰L$‰$èüÿÿÿ‹½ÿÿÿº‹µÿÿÿ‰T$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)׈vÿÿÿ‹|ÿÿÿ³Á≵øþÿÿt 𶿉t$‹…øþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßé+ÿÿÿƒøñÇE”N¿VUUU‰È÷ï‰ÈÁø)ÂJ‰•¤þÿÿˆ5úÿÿ“,E”‰•Xÿÿÿ}‰…@ÿÿÿ‹@‰½0ÿÿÿ“T‰Tÿÿÿ‰•Pÿÿÿë*‰×)÷G„Å9Ö„ÿ¤þÿÿz‰}”ˆØùÿÿ‹Mˆ‹1‹U”‰ñB9Æ~‰Á‰M9ðÁ‹UŒ¿‹ ‰‹0‹…Xÿÿÿ‰$èüÿÿÿ‰|$‹µ@ÿÿÿ‹ÿÿÿ‰t$‰ $èüÿÿÿ‹½ÿÿÿº‹…0ÿÿÿ‰T$‰<$‰D$èüÿÿÿ‹u‹U”‰÷)×x=‹…|ÿÿÿ³Á≵ þÿÿtðv‰t$‹ þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”é#ÿÿÿ‹UŒ¾‹:‰»‹`ÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿ‹…<ÿÿÿ‰<$‰D$èüÿÿÿ‹,ÿÿÿº‹µÿÿÿ‰T$‰L$‰4$èüÿÿÿ‹E‹U”‰Ç)׈úÿÿ‹…|ÿÿÿ³Á≵¬þÿÿtð´&¼'‰t$‹¬þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”éíøÿÿ‹UŒ¿‹ ‰‹‹µ\ÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…<ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ,ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈Xùÿÿ‹…|ÿÿÿ³Á≵¨þÿÿtð´&¼'‰t$‹¨þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”é-øÿÿƒøŽ]ƒøÀÇE”~‰ùÁéÏÑÿO‰½àþÿÿˆ[÷ÿÿU”E‰•Üþÿÿ‰…Øþÿÿ‹M”‰òA9Æ~‰Â‰U9΄ˋUŒƒd‹:‰»h‰$èüÿÿÿ‹µÜþÿÿ¹‹½ÿÿÿ‰L$‰t$‰<$èüÿÿÿ‹…Øþÿÿº‹ÿÿÿ‰T$‰D$‰ $èüÿÿÿ‹u‹U”‰÷)×x?‹|ÿÿÿ³Á≵Ôþÿÿt ðt&‰t$‹…Ôþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿàþÿÿˆuöÿÿ‹}ˆ‹7é"ÿÿÿÇE”F‰ÁÁéÈÑøH‰…”þÿÿˆKöÿÿ‹hE”‰Lÿÿÿ}‰…Dÿÿÿ“|‰½4ÿÿÿ‰•Hÿÿÿë"‰×)÷G„‘ÿ”þÿÿz‰}”ˆöÿÿ‹Uˆ‹2‹U”‰ñB9Æ~‰Á‰Mz9÷Æ‹UŒ‹:‰»l‹Lÿÿÿ‰ $èüÿÿÿ‹µDÿÿÿ¸‹½ÿÿÿ‰D$‰t$‰<$èüÿÿÿ‹4ÿÿÿº‹…ÿÿÿ‰T$‰L$‰$èüÿÿÿ‹u‹U”‰÷)×xD‹…|ÿÿÿ³Á≵þÿÿtðv¼'‰t$‹þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßèüÿÿÿ‹U”éÿÿÿ‹UŒ¾‹:‰»D‹Tÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿ‹…@ÿÿÿ‰<$‰D$èüÿÿÿ‹0ÿÿÿº‹µÿÿÿ‰T$‰L$‰4$èüÿÿÿ‹E‹U”‰Ç)׈¨ûÿÿ‹…|ÿÿÿ³Á≵œþÿÿtð‰t$‹œþÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßéiûÿÿ‹UŒ¾‹:‰»€‹Hÿÿÿ‰ $èüÿÿÿ‰t$‹½ÿÿÿ‹…Dÿÿÿ‰<$‰D$èüÿÿÿ‹4ÿÿÿº‹µÿÿÿ‰T$‰L$‰4$èüÿÿÿ‹E‹U”‰Ç)׈Þþÿÿ‹…|ÿÿÿ³Á≵Œþÿÿtð‰t$‹Œþÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßéŸþÿÿFélòÿÿ‹UŒ¿‹ ‰‹X‹µPÿÿÿ‰4$èüÿÿÿ‰|$‹•ÿÿÿ‹…@ÿÿÿ‰$‰D$èüÿÿÿ‹½ÿÿÿ¹‹µ0ÿÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹U”‰Ç)׈Lúÿÿ‹…|ÿÿÿ³Á≵˜þÿÿtð‰t$‹˜þÿÿº‰T$ƒÆ‰ $èüÿÿÿOyßé úÿÿÇE”~‰ùÁéÏÑÿO‰½ôþÿÿˆóÿÿU”E‰•ðþÿÿ‰…ìþÿÿ‹M”‰òA9Æ~‰Â‰U9΄Á‹UŒƒ<‹:‰»@‰$èüÿÿÿ‹µðþÿÿ¹‹½ÿÿÿ‰L$‰t$‰<$èüÿÿÿ‹…ìþÿÿº‹ÿÿÿ‰T$‰D$‰ $èüÿÿÿ‹u‹U”‰÷)×x;‹|ÿÿÿ³Á≵èþÿÿt ð‰t$‹…èþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßèüÿÿÿƒE”ÿôþÿÿˆ%òÿÿ‹}ˆ‹7é&ÿÿÿ‹UŒ³P¿‹‰ƒT‰4$èüÿÿÿ‰|$‹ðþÿÿ‹•ÿÿÿ‰L$‰$èüÿÿÿ‹½ÿÿÿ¸‹µìþÿÿ‰D$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)׈vÿÿÿ‹|ÿÿÿ³Á≵äþÿÿt 𶿉t$‹…äþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßé+ÿÿÿ‹UŒ³x¿‹‰ƒ|‰4$èüÿÿÿ‰|$‹Üþÿÿ‹•ÿÿÿ‰L$‰$èüÿÿÿ‹½ÿÿÿ¸‹µØþÿÿ‰D$‰<$‰t$èüÿÿÿ‹M‹U”‰Ï)׈púÿÿ‹|ÿÿÿ³Á≵Ðþÿÿt ð‰t$‹…Ðþÿÿº‰T$ƒÆ‰$èüÿÿÿOyßé1úÿÿÇE”Nˆ­ðÿÿÁ¥ÿÿÿƒ‹•|ÿÿÿ‰…Ìþÿÿ‹Œ‹…ÿÿÿ‰ÿÿÿ}”‰½ÿÿÿLð‰xÿÿÿ‹EŒ‹‰‹‹•ÿÿÿ‰$èüÿÿÿ‰|$‹ÿÿÿ¸‰D$¿‰ $èüÿÿÿ‰|$‹•ÿÿÿ‹½ÿÿÿ‰$‰|$èüÿÿÿ‹xÿÿÿ¸‹•Ìþÿÿ‰D$‰L$‰$èüÿÿÿèüÿÿÿÿE”N‰{ÿÿÿéåïÿÿ(/,1X,A,/,1X,A)(1X,I4, - ,I4,:,1X,1P,2((,D10.3,,,D10.3,) ))(1X,I4, - ,I4,:,1X,1P,1((,D10.3,,,D10.3,) ))(1X,I4, - ,I4,:,1X,1P,2((,D12.5,,,D12.5,) ))(1X,I4, - ,I4,:,1X,1P,1((,D12.5,,,D12.5,) ))(1X,I4, - ,I4,:,1X,1P,2((,D14.7,,,D14.7,) ))(1X,I4, - ,I4,:,1X,1P,1((,D14.7,,,D14.7,) ))(1X,I4, - ,I4,:,1X,1P,1((,D20.13,,,D20.13,) ))(1X,I4, - ,I4,:,1X,1P,4((,D10.3,,,D10.3,) ))(1X,I4, - ,I4,:,1X,1P,3((,D10.3,,,D10.3,) ))(1X,I4, - ,I4,:,1X,1P,2((,D10.3,,,D10.3,) ))(1X,I4, - ,I4,:,1X,1P,1((,D10.3,,,D10.3,) ))(1X,I4, - ,I4,:,1X,1P,3((,D12.5,,,D12.5,) ))(1X,I4, - ,I4,:,1X,1P,2((,D12.5,,,D12.5,) ))(1X,I4, - ,I4,:,1X,1P,1((,D12.5,,,D12.5,) ))(1X,I4, - ,I4,:,1X,1P,3((,D14.7,,,D14.7,) ))(1X,I4, - ,I4,:,1X,1P,2((,D14.7,,,D14.7,) ))(1X,I4, - ,I4,:,1X,1P,1((,D14.7,,,D14.7,) ))(1X,I4, - ,I4,:,1X,1P,2((,D20.13,,,D20.13,) ))(1X,I4, - ,I4,:,1X,1P,1((,D20.13,,,D20.13,) ))(1X, ) ` à ` à ` à ` à ` Ù- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ „$ %`á +D4D¤0 œ)¨ DèLìYô€øø#™ à7 ì —ñÿ .? 7S(d`7x<‰ 7P®à7ÂdÔ 7éxû`7Œ" 97 Ià7^´p 7…Ș`7­ÜÀ 7Õðèà7ý 7%8`7M,` 7u@ˆà7T° 7ÅhØ`9í| 9(Ù  =B GN e{‚‰zvout.f__g77_cilist_0.1__g77_format_9999.0__g77_cilist_1.3__g77_format_9998.2__g77_cilist_2.5__g77_format_9997.4__g77_cilist_3.7__g77_format_9988.6__g77_cilist_4.9__g77_format_9987.8__g77_cilist_5.11__g77_format_9978.10__g77_cilist_6.13__g77_format_9977.12__g77_cilist_7.15__g77_format_9968.14__g77_cilist_8.17__g77_format_9958.16__g77_cilist_9.19__g77_format_9957.18__g77_cilist_10.21__g77_format_9956.20__g77_cilist_11.23__g77_format_9955.22__g77_cilist_12.25__g77_format_9948.24__g77_cilist_13.27__g77_format_9947.26__g77_cilist_14.29__g77_format_9946.28__g77_cilist_15.31__g77_format_9938.30__g77_cilist_16.33__g77_format_9937.32__g77_cilist_17.35__g77_format_9936.34__g77_cilist_18.37__g77_format_9928.36__g77_cilist_19.39__g77_format_9927.38__g77_cilist_20.41__g77_format_9994.40.LC2.LC3zvout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfe8 9R 0:¥ 0á:ó û ;  4%<D<I=Ÿ · Ã Ï 3 A;b<ƒ<› 5Ê<Ò=ð ø ;=B Z f à Ñ;í<<& 5Z<b=z ˆ;¤<Å<á 5<"=: H;d<…<¡ 5Ú<â=ú ;$<E<a 5š<¢=   ;@<\<t 5ª<²=Õ â ê;<'<C 5z<¸ Ð Ü 9 G ;c <„ <œ 5Ê <Ò =ê ø ; <5 <Q 5Š <’ =ª ¸ ;Ô <õ < 5J <R =À È Ð ;ñ < <* 5Z <b =¢ º   ;< <] <u 5ª <² =Ê Ø ;ô <<1 5\<t ‚;ž<¿<Û 5<& 4;P<q< 5¸<  $;E<f<~ 5ª<²=Õ â ê;<'<C 5z<‹ ˜  ;¼<Ý<ù 5$<G 5Y ƒ ‘;±<Í<î<ó=  4H\p„˜¬ÀÔèü$8L`tˆœzmout.o/ 1189291774 1000 1000 100644 13676 ` ELFL"4( U‰åWVSìL‹u ‹UèüÿÿÿËM‹E‰uˆ‹u$‰U€‹}‰hÿÿÿƒþP‰EŒ‹‰}„‰µ|ÿÿÿ‰…xÿÿÿ‰µpÿÿÿ~ ºP‰•pÿÿÿ‹µpÿÿÿM˜‰ÿÿÿNxDÇE”»ë‰E”‰|$¹‹•ÿÿÿ‰L$ ‹M”¸‰D$D ÿ‰$èüÿÿÿ‹E”@NyË‹µpÿÿÿF‰÷‰u”÷׉þƒÆQx7»‰|$¹‹•ÿÿÿ‰L$ ‹M”¸‰D$D ÿ‰$èüÿÿÿÿE”NyÏ‹}Œƒ‹»‰‹‰$èüÿÿÿ‰½ÿÿÿ‹•|ÿÿÿ‹u ‰<$‰T$‰t$èüÿÿÿ‹pÿÿÿ‹•ÿÿÿ‹…ÿÿÿ‰L$‰$‰D$èüÿÿÿèüÿÿÿ‹uˆ‹>…ÿŽè‹u„‹…ÉŽÛ‹U€‹…ÀŽÎ‹}‹…À‰Âu¸…Òˆ`ƒøÀ‰ÈƒÀˆšÇEÁøH‰…<þÿÿˆm»ð‰½ÿÿÿ‰8þÿÿ‹EƒÀ9Á~‰…8þÿÿ‹UŒ‹:‰»ô‹…ÿÿÿ‰$èüÿÿÿ‹M‹µ8þÿÿ‰M”)Îxgƒ‹‰…4þÿÿ}”‰0þÿÿv¼'‹•4þÿÿ¹‹…0þÿÿ‰L$‰T$‰$èüÿÿÿ‰|$‹•ÿÿÿ¹‰L$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µ,þÿÿˆÆƒ‹M»‰…Pÿÿÿ‹…xÿÿÿ³,‰½Lÿÿÿ“@‰µHÿÿÿÁà‰•Dÿÿÿ‰…¸þÿÿ‰…¼þÿÿ‰…°þÿÿ‰…´þÿÿë+‰È)Ѓøþ„@„£9Ê„KÿE”ÿ,þÿÿˆÆ‹u„y‹9×É‹MŒ‹1‰³‹½Pÿÿÿ‰<$èüÿÿÿ‹ÿÿÿ¸U”‰D$‰T$‰ $èüÿÿÿ‹E‹½8þÿÿ)Çx_‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰(þÿÿ4t&¼'‹E”º‰T$‹•(þÿÿÁàLð‰L$‰$èüÿÿÿ‹…¼þÿÿÆOyÐèüÿÿÿ‹MÿE”ÿ,þÿÿ‰:ÿÿÿÿ<þÿÿy‰}ˆD‹u„‹éÙýÿÿ‹UŒu”‹:‰»‹…Lÿÿÿ‰$èüÿÿÿ‰t$‹½ÿÿÿ¹‰L$‰<$èüÿÿÿ‹E‹½8þÿÿ)Çx‰‹µxÿÿÿÁàƒè‹hÿÿÿ“¯Æ‰•$þÿÿ4t&‹E”¹‰L$‹$þÿÿÁàTð‰T$‰ $èüÿÿÿ‹…¸þÿÿÆOyÐèüÿÿÿ‹Mé+ÿÿÿ‹}Œu”‹‰‹0‹…Hÿÿÿ‰$èüÿÿÿ‰t$‹½ÿÿÿº‰T$‰<$èüÿÿÿ‹E‹½8þÿÿ)LjÛþÿÿ‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰ þÿÿ4´&‹E”º‰T$‹• þÿÿÁàLð‰L$‰$èüÿÿÿ‹…´þÿÿÆOyÐèüÿÿÿ‹Mé{þÿÿ‹UŒu”‹:‰»D‹…Dÿÿÿ‰$èüÿÿÿ‰t$‹½ÿÿÿ¹‰L$‰<$èüÿÿÿ‹E‹½8þÿÿ)Lj+þÿÿ‹µxÿÿÿÁàƒè‹hÿÿÿ“¯Æ‰•þÿÿ4´&‹E”¹‰L$‹þÿÿÁàTð‰T$‰ $èüÿÿÿ‹…°þÿÿÆOyÐèüÿÿÿ‹MéËýÿÿƒøÇEq¿VUUU‰ð÷ï‰ðÁø)ÂJ‰•øýÿÿ‰ ‹UŒ»0‹2‰³4‰<$èüÿÿÿèüÿÿÿÄL[^_]ËMéyýÿÿƒøšÇEq¿VUUU‰ð÷ï‰ðÁø)ÂJ‰•þÿÿx§“T‰•ÿÿÿ‰þÿÿ‹EƒÀ9Á~‰…þÿÿ‹UŒ‹‰ƒX‹½ÿÿÿ‰<$èüÿÿÿ‹M‹µþÿÿ‰M”)Îxa»‹‰½þÿÿ}”‰ þÿÿt&‹ þÿÿº‹…þÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µþÿÿˆ‹…xÿÿÿ»h‹M‰½@ÿÿÿ³|Áà‰µ<ÿÿÿ“‰•8ÿÿÿ‰…Äþÿÿ‰…Èþÿÿ‰…Àþÿÿë"‰Ï)×G„ô9Ê„–ÿE”ÿþÿÿˆÁ‹u„A‹9ÐÒ‹MŒ¿‹1‰³l‹…@ÿÿÿ‰$èüÿÿÿ‰|$‹ÿÿÿU”‰T$‰ $èüÿÿÿ‹E‹½þÿÿ)ÇxZ‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰þÿÿ4¶‹E”º‰T$‹•þÿÿÁàLð‰L$‰$èüÿÿÿ‹…ÈþÿÿÆOyÐèüÿÿÿ‹MÿE”ÿþÿÿ‰?ÿÿÿÿþÿÿy‰}ˆ¤ýÿÿ‹u„‹éÿýÿÿ‹uŒ‹>‰»€‹•<ÿÿÿ‰$èüÿÿÿ‹µÿÿÿ¸M”‰D$‰L$‰4$èüÿÿÿ‹E‹½þÿÿ)Çx‰‹•xÿÿÿÁàƒè‹hÿÿÿ³¯Â‰µþÿÿ4t&‹E”¹‰L$‹þÿÿÁàTð‰T$‰ $èüÿÿÿ‹…ÄþÿÿÆOyÐèüÿÿÿ‹Mé+ÿÿÿ‹}Œu”‹‰‹”‹…8ÿÿÿ‰$èüÿÿÿ‰t$‹½ÿÿÿº‰T$‰<$èüÿÿÿ‹E‹½þÿÿ)LjÛþÿÿ‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰üýÿÿ4´&‹E”º‰T$‹•üýÿÿÁàLð‰L$‰$èüÿÿÿ‹…ÀþÿÿÆOyÐèüÿÿÿ‹Mé{þÿÿ‹Mé‚þÿÿ‰Ð÷؃ø ÇEq‰ðÁèÆÑþN‰µ”þÿÿˆ üÿÿ“‰•ìþÿÿ‰tÿÿÿ‹E@9Á~‰…tÿÿÿ‹UŒ‹‰ƒ‹µìþÿÿ‰4$èüÿÿÿ‹M‹µtÿÿÿ‰M”)Îxg»‹‰½üþÿÿ}”‰ðþÿÿv¼'‹üþÿÿº‹…ðþÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µþÿÿˆ‹xÿÿÿu”“(‰µŒþÿÿƒ<Áቕlÿÿÿ‰…dÿÿÿ‰˜þÿÿ‰œþÿÿv¼'‹M„‹}99„§ ‹EŒ¾‹‰‹,‹½lÿÿÿ‰<$èüÿÿÿ‰t$‹•Œþÿÿ‹…ÿÿÿ‰T$‰$èüÿÿÿ‹E‹½tÿÿÿ)Çx[‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰øþÿÿ4´&‹E”º‰T$‹•øþÿÿÁàLð‰L$‰$èüÿÿÿ‹…œþÿÿÆOyÐèüÿÿÿÿE”ÿþÿÿ‰<ÿÿÿƒEÿ”þÿÿˆ)úÿÿ‹}„‹é þÿÿƒøŽ,ƒø+ ÇEy‰þÁî÷ÑÿO‰½dþÿÿˆíùÿÿƒŒ‰…ÿÿÿ‰`þÿÿ‹E@9Á~‰…`þÿÿ‹EŒ‹0‰³‹½ÿÿÿ‰<$èüÿÿÿ‹M‹µ`þÿÿ‰M”)Îx]‹“‰\þÿÿ}”‰•Xþÿÿ‹Xþÿÿº‹…\þÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹uˆ‹>ÇE”O‰½Tþÿÿˆ‹xÿÿÿ}”“ ‰½Pþÿÿƒ´ÁቕXÿÿÿ‰…Tÿÿÿ‰¨þÿÿ‰¬þÿÿ‹M„‹u91„O ‹EŒ¿‹‰‹¤‹µXÿÿÿ‰4$èüÿÿÿ‰|$‹•Pþÿÿ‹…ÿÿÿ‰T$‰$èüÿÿÿ‹E‹½`þÿÿ)Çxa‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰Lþÿÿ4¶¼'‹E”º‰T$‹•LþÿÿÁàLð‰L$‰$èüÿÿÿ‹…¬þÿÿÆOyÐèüÿÿÿÿE”ÿTþÿÿ‰6ÿÿÿƒEÿdþÿÿˆøÿÿ‹U„‹ é.þÿÿÇEq‰ðÁèÆÑþN‰µØýÿÿˆï÷ÿÿ“ô‰•ôþÿÿ‰Ôýÿÿ‹E@9Á~‰…Ôýÿÿ‹UŒ‹‰ƒø‹µôþÿÿ‰4$èüÿÿÿ‹M‹µÔýÿÿ‰M”)Îxk»‹‰½Ìýÿÿ}”‰Ðýÿÿ´&¼'‹Ìýÿÿº‹…Ðýÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µÈýÿÿˆ‹xÿÿÿu”“‰µÄýÿÿƒÁቕ(ÿÿÿ‰…$ÿÿÿ‰Øþÿÿ‰Üþÿÿv¼'‹M‹}„A;ß‹EŒ¾‹‰‹ ‹½(ÿÿÿ‰<$èüÿÿÿ‰t$‹•Äýÿÿ‹…ÿÿÿ‰T$‰$èüÿÿÿ‹E‹½Ôýÿÿ)ÇxZ‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰Àýÿÿ4¶‹E”º‰T$‹•ÀýÿÿÁàLð‰L$‰$èüÿÿÿ‹…ÜþÿÿÆOyÐèüÿÿÿÿE”ÿÈýÿÿ‰<ÿÿÿƒEÿØýÿÿˆ öÿÿ‹}„‹éþÿÿ“¤‰• ÿÿÿ‰ôýÿÿ‹EƒÀ9Á~‰…ôýÿÿ‹UŒ‹‰ƒ¨‹½ ÿÿÿ‰<$èüÿÿÿ‹M‹µôýÿÿ‰M”)Îxi»‹‰½ðýÿÿ}”‰ìýÿÿ¶¿‹ìýÿÿº‹…ðýÿÿ‰T$‰ $‰D$èüÿÿÿ‰|$‹…ÿÿÿº‰T$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹}ˆ‹7ÇE”N‰µèýÿÿˆ;‹…xÿÿÿ»¸‹M‰½4ÿÿÿ³ÌÁà‰µ0ÿÿÿ“à‰•,ÿÿÿ‰…Ðþÿÿ‰…Ôþÿÿ‰…Ìþÿÿë"‰Ï)×G„ö9Ê„—ÿE”ÿèýÿÿˆÁ‹u„A‹9ÐÒ‹MŒ¿‹1‰³¼‹…4ÿÿÿ‰$èüÿÿÿ‰|$‹ÿÿÿU”‰T$‰ $èüÿÿÿ‹E‹½ôýÿÿ)ÇxZ‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰äýÿÿ4¶‹E”º‰T$‹•äýÿÿÁàLð‰L$‰$èüÿÿÿ‹…ÔþÿÿÆOyÐèüÿÿÿ‹MÿE”ÿèýÿÿ‰?ÿÿÿÿøýÿÿy‰}ˆôóÿÿ‹u„‹é÷ýÿÿÇEy‰þÁî÷ÑÿO‰½„þÿÿˆÊóÿÿ“P‰• ÿÿÿ‰€þÿÿ‹E@9Á~‰…€þÿÿ‹UŒ‹2‰³T‹½ ÿÿÿ‰<$èüÿÿÿ‹M‹µ€þÿÿ‰M”)Îx]‹ƒ‰|þÿÿ}”‰…xþÿÿ‹•|þÿÿ¸‹xþÿÿ‰D$‰T$‰ $èüÿÿÿ‰|$‹•ÿÿÿ¸‰D$‰$èüÿÿÿÿE”Ny¾èüÿÿÿ‹uˆ‹>ÇE”O‰½tþÿÿˆý‹xÿÿÿ}”ƒd‰½pþÿÿ“xÁቅ`ÿÿÿ‰•\ÿÿÿ‰ þÿÿ‰¤þÿÿ‹M„‹u91„*‹UŒ¿‹ ‰‹h‹µ`ÿÿÿ‰4$èüÿÿÿ‰|$‹…pþÿÿ‹•ÿÿÿ‰D$‰$èüÿÿÿ‹E‹½€þÿÿ)Çx^‹µxÿÿÿÁàƒè‹hÿÿÿ“¯Æ‰•lþÿÿ4v¼'‹E”¹‰L$‹lþÿÿÁàTð‰T$‰ $èüÿÿÿ‹…¤þÿÿÆOyÐèüÿÿÿÿE”ÿtþÿÿ‰9ÿÿÿƒEÿ„þÿÿˆùñÿÿ‹E„‹é1þÿÿ‹UŒ‹:‰» ‹…$ÿÿÿ‰$èüÿÿÿ‹½ÿÿÿ¹‹µÄýÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹½Ôýÿÿ)Ljwûÿÿ‹µxÿÿÿÁàƒè‹hÿÿÿ“¯Æ‰•¼ýÿÿ4v‹E”¹‰L$‹¼ýÿÿÁàTð‰T$‰ $èüÿÿÿ‹…ØþÿÿÆOyÐéûÿÿ‹UŒ‹:‰»@‹…dÿÿÿ‰$èüÿÿÿ‹½ÿÿÿ¹‹µŒþÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹½tÿÿÿ)Lj°öÿÿ‹µxÿÿÿÁàƒè‹hÿÿÿ“¯Æ‰•ˆþÿÿ4¶¿‹E”¹‰L$‹ˆþÿÿÁàTð‰T$‰ $èüÿÿÿ‹…˜þÿÿÆOyÐéKöÿÿ‹}Œ‹‰‹|‹…\ÿÿÿ‰$èüÿÿÿ‹½ÿÿÿº‹µpþÿÿ‰T$‰<$‰t$èüÿÿÿ‹E‹½€þÿÿ)Lj0þÿÿ‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰hþÿÿ4¶¿‹E”º‰T$‹•hþÿÿÁàLð‰L$‰$èüÿÿÿ‹… þÿÿÆOyÐéËýÿÿ‹uŒ‹>‰»Ð‹•0ÿÿÿ‰$èüÿÿÿ‹µÿÿÿ¸M”‰D$‰L$‰4$èüÿÿÿ‹E‹½ôýÿÿ)Ljƒûÿÿ‹•xÿÿÿÁàƒè‹hÿÿÿ³¯Â‰µàýÿÿ4‹E”¹‰L$‹àýÿÿÁàTð‰T$‰ $èüÿÿÿ‹…ÐþÿÿÆOyÐèüÿÿÿ‹Mé*ûÿÿ‹}Œu”‹‰‹ä‹…,ÿÿÿ‰$èüÿÿÿ‰t$‹½ÿÿÿº‰T$‰<$èüÿÿÿ‹E‹½ôýÿÿ)LjÚúÿÿ‹µxÿÿÿÁàƒè‹•hÿÿÿ‹¯Æ‰Üýÿÿ4‹E”º‰T$‹•ÜýÿÿÁàLð‰L$‰$èüÿÿÿ‹…ÌþÿÿÆOyÐèüÿÿÿ‹Méúÿÿ‹UŒ‹:‰»¸‹…Tÿÿÿ‰$èüÿÿÿ‹½ÿÿÿ¹‹µPþÿÿ‰L$‰<$‰t$èüÿÿÿ‹E‹½`þÿÿ)Ljöÿÿ‹µxÿÿÿÁàƒè‹hÿÿÿ“¯Æ‰•Hþÿÿ4‹E”¹‰L$‹HþÿÿÁàTð‰T$‰ $èüÿÿÿ‹…¨þÿÿÆOyÐéµõÿÿ‹MéäùÿÿAé^éÿÿÇE‰ÏOˆÒíÿÿƒ“‰…Dþÿÿ³È‰•@þÿÿM‰µÿÿÿE”‰ÿÿÿ“‰…èþÿÿ³Ü‰•äþÿÿ‰µàþÿÿ‹uŒ‹‰“Ì‹ÿÿÿ‰ $èüÿÿÿ‹•Dþÿÿ¸‹µ@þÿÿ‰D$‰T$‰4$èüÿÿÿ‹•ÿÿÿ¹‹…ÿÿÿ‰L$‰$‰D$èüÿÿÿèüÿÿÿ‹uˆ‹ÇE”‰Îë‹UŒ‹‰ƒà‹àþÿÿ‰ $èüÿÿÿ‹•èþÿÿ¸‹ÿÿÿ‰D$‰T$‰ $èüÿÿÿ¸‹•xÿÿÿ‹hÿÿÿ‰D$‹EH¯Â‹U”ÁàÁâÈLð‰L$‹…äþÿÿ‰$èüÿÿÿèüÿÿÿÿE”N‰zÿÿÿÿEO‰ÿÿÿéìÿÿCol(/,1X,A,/,1X,A)(11X,4(9X,3A1,I4,9X))(10X,4(11X,3A1,I4,11X))(10X,3(13X,3A1,I4,13X))(12X,2(18X,3A1,I4,18X))(1X, Row,I4,:,1X,1P,2((,D10.3,,,D10.3,) ))(1X, Row,I4,:,1X,1P,1((,D10.3,,,D10.3,) ))(1X, Row,I4,:,1X,1P,2((,D12.5,,,D12.5,) ))(1X, Row,I4,:,1X,1P,1((,D12.5,,,D12.5,) ))(1X, Row,I4,:,1X,1P,2((,D14.7,,,D14.7,) ))(1X, Row,I4,:,1X,1P,1((,D14.7,,,D14.7,) ))(1X, Row,I4,:,1X,1P,1((,D20.13,,,D20.13,)))(1X, )(1X, Row,I4,:,1X,1P,4((,D10.3,,,D10.3,) ))(1X, Row,I4,:,1X,1P,3((,D10.3,,,D10.3,) ))(1X, Row,I4,:,1X,1P,2((,D10.3,,,D10.3,) ))(1X, Row,I4,:,1X,1P,1((,D10.3,,,D10.3,) ))(1X, Row,I4,:,1X,1P,3((,D12.5,,,D12.5,) ))(1X, Row,I4,:,1X,1P,2((,D12.5,,,D12.5,) ))(1X, Row,I4,:,1X,1P,1((,D12.5,,,D12.5,) ))(1X, Row,I4,:,1X,1P,3((,D14.7,,,D14.7,) ))(1X, Row,I4,:,1X,1P,2((,D14.7,,,D14.7,) ))(1X, Row,I4,:,1X,1P,1((,D14.7,,,D14.7,) ))(1X, Row,I4,:,1X,1P,2((,D20.13,,,D20.13,) ))(1X, Row,I4,:,1X,1P,1((,D20.13,,,D20.13,) ))€À'@>€ÀU@€À'@€À>@€UÀ5- ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@¾ ô- %7 +848D0 „4è D|!L€! YŒ!€!!#³!™¤$ÀE d)ñÿ !5FZ(k€5<À5¤P¶'ÊdÜ5ñx@5Œ*>? Q€5f´xÀ5È UµÜÈ5Ýðð@5+€5@,SÀ5h@{5T£h¶@5Ë|Þ€5óÀ5¤.¸A5VÌi@5~à‘€5¦ô¹ÌÀ7áô7 05  16; @¾G ^t{‚‰zmout.ficol.0__g77_cilist_0.2__g77_format_9999.1__g77_cilist_1.4__g77_format_9998.3__g77_cilist_2.6__g77_format_9994.5__g77_cilist_3.8__g77_format_9984.7__g77_cilist_4.10__g77_format_9997.9__g77_cilist_5.12__g77_format_9993.11__g77_cilist_6.14__g77_format_9983.13__g77_cilist_7.16__g77_format_9996.15__g77_cilist_8.18__g77_format_9992.17__g77_cilist_9.20__g77_format_9982.19__g77_cilist_10.22__g77_format_9995.21__g77_cilist_11.24__g77_format_9991.23__g77_cilist_12.25__g77_cilist_13.27__g77_format_9974.26__g77_cilist_14.29__g77_format_9964.28__g77_cilist_15.31__g77_format_9954.30__g77_cilist_16.33__g77_format_9944.32__g77_cilist_17.34__g77_cilist_18.36__g77_format_9973.35__g77_cilist_19.38__g77_format_9963.37__g77_cilist_20.40__g77_format_9953.39__g77_cilist_21.41__g77_cilist_22.43__g77_format_9972.42__g77_cilist_23.45__g77_format_9962.44__g77_cilist_24.47__g77_format_9952.46__g77_cilist_25.48__g77_cilist_26.50__g77_format_9971.49__g77_cilist_27.52__g77_format_9961.51__g77_cilist_28.54__g77_format_9990.53.LC2.LC3.LC4zmout___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_copys_wsfedo_fioe_wsfeF Gz =ªHÌ =÷H  A I;J]JbKÒ ù I # B]JxJƒK¢ « ½ É 4 BI`J… CÁJÑK  I6J[ C‘J¡K· ÅIàJ  CAJQKg uIJ¹ CñJKB J RIWK˜ ¿ ÍIã é BJ8JCKh w † Þ ìIJ* CaJqKª ¸IÖJû C1 JA KW e I€ J© Cá Jñ K4 Y g I} Bƒ ½ JØ Jã K  Z h I„ J© Cá Jñ KR w … I› ¡ BÑ Jì J÷ K + d r IŽ J³ Cñ JKP u ƒI™ BŸ ÝJøJK+ 7 { ‰I¥JÊ CJK@ g uI‹ ‘ BÍJèJóK ' 6 Ž œIµJÚ CJ!Ku š ¨I¾ Ä BôJJKB N ‡ •I±JÖ CJ!KU cI„J­ CáJü  I+JT C‘J¬ ºIÛJ CAJ\ jIˆJ± CâJòK I1JZ C‹J›K® ¼IÝJ C7Jm s B  C© À ÎIïJJK0 >I_JœJ¡K  4H\p„˜¬ÀÔèü$8L`tˆœ°ÄØì(<arpack-akloeckner-07/SRC/0000755000175000017500000000000010670624160015124 5ustar andreasandreasarpack-akloeckner-07/SRC/dgetv0.f0000644000175000017500000003164210670622032016466 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dgetv0 c c\Description: c Generate a random initial residual vector for the Arnoldi process. c Force the residual vector to be in the range of the operator OP. c c\Usage: c call dgetv0 c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, c IPNTR, WORKD, IERR ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to dgetv0. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B in the (generalized) c eigenvalue problem A*x = lambda*B*x. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c ITRY Integer. (INPUT) c ITRY counts the number of times that dgetv0 is called. c It should be set to 1 on the initial call to dgetv0. c c INITV Logical variable. (INPUT) c .TRUE. => the initial residual vector is given in RESID. c .FALSE. => generate a random initial residual vector. c c N Integer. (INPUT) c Dimension of the problem. c c J Integer. (INPUT) c Index of the residual vector to be generated, with respect to c the Arnoldi process. J > 1 in case of a "restart". c c V Double precision N by J array. (INPUT) c The first J-1 columns of V contain the current Arnoldi basis c if this is a "restart". c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c RESID Double precision array of length N. (INPUT/OUTPUT) c Initial residual vector to be generated. If RESID is c provided, force RESID into the range of the operator OP. c c RNORM Double precision scalar. (OUTPUT) c B-norm of the generated residual. c c IPNTR Integer array of length 3. (OUTPUT) c c WORKD Double precision work array of length 2*N. (REVERSE COMMUNICATION). c On exit, WORK(1:N) = B*RESID to be used in SSAITR. c c IERR Integer. (OUTPUT) c = 0: Normal exit. c = -1: Cannot generate a nontrivial restarted residual vector c in the range of the operator OP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c arscnd ARPACK utility routine for timing. c dvout ARPACK utility routine for vector output. c dlarnv LAPACK routine for generating a random vector. c dgemv Level 2 BLAS routine for matrix vector multiplication. c dcopy Level 1 BLAS that copies one vector to another. c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dgetv0 & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, & ipntr, workd, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 logical initv integer ido, ierr, itry, j, ldv, n Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Double precision & resid(n), v(ldv,j), workd(2*n) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical first, inits, orth integer idist, iseed(4), iter, msglvl, jj Double precision & rnorm0 save first, iseed, inits, iter, msglvl, orth, rnorm0 c c %----------------------% c | External Subroutines | c %----------------------% c external dlarnv, dvout, dcopy, dgemv, arscnd c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2 external ddot, dnrm2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, sqrt c c %-----------------% c | Data Statements | c %-----------------% c data inits /.true./ c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-----------------------------------% c | Initialize the seed of the LAPACK | c | random number generator | c %-----------------------------------% c if (inits) then iseed(1) = 1 iseed(2) = 3 iseed(3) = 5 iseed(4) = 7 inits = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mgetv0 c ierr = 0 iter = 0 first = .FALSE. orth = .FALSE. c c %-----------------------------------------------------% c | Possibly generate a random starting vector in RESID | c | Use a LAPACK random number generator used by the | c | matrix generation routines. | c | idist = 1: uniform (0,1) distribution; | c | idist = 2: uniform (-1,1) distribution; | c | idist = 3: normal (0,1) distribution; | c %-----------------------------------------------------% c if (.not.initv) then idist = 2 call dlarnv (idist, iseed, n, resid) end if c c %----------------------------------------------------------% c | Force the starting vector into the range of OP to handle | c | the generalized problem when B is possibly (singular). | c %----------------------------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nopx = nopx + 1 ipntr(1) = 1 ipntr(2) = n + 1 call dcopy (n, resid, 1, workd, 1) ido = -1 go to 9000 end if end if c c %-----------------------------------------% c | Back from computing OP*(initial-vector) | c %-----------------------------------------% c if (first) go to 20 c c %-----------------------------------------------% c | Back from computing B*(orthogonalized-vector) | c %-----------------------------------------------% c if (orth) go to 40 c if (bmat .eq. 'G') then call arscnd (t3) tmvopx = tmvopx + (t3 - t2) end if c c %------------------------------------------------------% c | Starting vector is now in the range of OP; r = OP*r; | c | Compute B-norm of starting vector. | c %------------------------------------------------------% c call arscnd (t2) first = .TRUE. if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, workd(n+1), 1, resid, 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd, 1) end if c 20 continue c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c first = .FALSE. if (bmat .eq. 'G') then rnorm0 = ddot (n, resid, 1, workd, 1) rnorm0 = sqrt(abs(rnorm0)) else if (bmat .eq. 'I') then rnorm0 = dnrm2(n, resid, 1) end if rnorm = rnorm0 c c %---------------------------------------------% c | Exit if this is the very first Arnoldi step | c %---------------------------------------------% c if (j .eq. 1) go to 50 c c %---------------------------------------------------------------- c | Otherwise need to B-orthogonalize the starting vector against | c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | c | This is the case where an invariant subspace is encountered | c | in the middle of the Arnoldi factorization. | c | | c | s = V^{T}*B*r; r = r - V*s; | c | | c | Stopping criteria used for iter. ref. is discussed in | c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | c %---------------------------------------------------------------% c orth = .TRUE. 30 continue c call dgemv ('T', n, j-1, one, v, ldv, workd, 1, & zero, workd(n+1), 1) call dgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, & one, resid, 1) c c %----------------------------------------------------------% c | Compute the B-norm of the orthogonalized starting vector | c %----------------------------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd, 1) end if c 40 continue c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if c c %--------------------------------------% c | Check for further orthogonalization. | c %--------------------------------------% c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm0, ndigit, & '_getv0: re-orthonalization ; rnorm0 is') call dvout (logfil, 1, rnorm, ndigit, & '_getv0: re-orthonalization ; rnorm is') end if c if (rnorm .gt. 0.717*rnorm0) go to 50 c iter = iter + 1 if (iter .le. 5) then c c %-----------------------------------% c | Perform iterative refinement step | c %-----------------------------------% c rnorm0 = rnorm go to 30 else c c %------------------------------------% c | Iterative refinement step "failed" | c %------------------------------------% c do 45 jj = 1, n resid(jj) = zero 45 continue rnorm = zero ierr = -1 end if c 50 continue c if (msglvl .gt. 0) then call dvout (logfil, 1, rnorm, ndigit, & '_getv0: B-norm of initial / restarted starting vector') end if if (msglvl .gt. 3) then call dvout (logfil, n, resid, ndigit, & '_getv0: initial / restarted starting vector') end if ido = 99 c call arscnd (t1) tgetv0 = tgetv0 + (t1 - t0) c 9000 continue return c c %---------------% c | End of dgetv0 | c %---------------% c end arpack-akloeckner-07/SRC/dlaqrb.f0000644000175000017500000004402006210503372016534 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dlaqrb c c\Description: c Compute the eigenvalues and the Schur decomposition of an upper c Hessenberg submatrix in rows and columns ILO to IHI. Only the c last component of the Schur vectors are computed. c c This is mostly a modification of the LAPACK routine dlahqr. c c\Usage: c call dlaqrb c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO ) c c\Arguments c WANTT Logical variable. (INPUT) c = .TRUE. : the full Schur form T is required; c = .FALSE.: only eigenvalues are required. c c N Integer. (INPUT) c The order of the matrix H. N >= 0. c c ILO Integer. (INPUT) c IHI Integer. (INPUT) c It is assumed that H is already upper quasi-triangular in c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless c ILO = 1). SLAQRB works primarily with the Hessenberg c submatrix in rows and columns ILO to IHI, but applies c transformations to all of H if WANTT is .TRUE.. c 1 <= ILO <= max(1,IHI); IHI <= N. c c H Double precision array, dimension (LDH,N). (INPUT/OUTPUT) c On entry, the upper Hessenberg matrix H. c On exit, if WANTT is .TRUE., H is upper quasi-triangular in c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in c standard form. If WANTT is .FALSE., the contents of H are c unspecified on exit. c c LDH Integer. (INPUT) c The leading dimension of the array H. LDH >= max(1,N). c c WR Double precision array, dimension (N). (OUTPUT) c WI Double precision array, dimension (N). (OUTPUT) c The real and imaginary parts, respectively, of the computed c eigenvalues ILO to IHI are stored in the corresponding c elements of WR and WI. If two eigenvalues are computed as a c complex conjugate pair, they are stored in consecutive c elements of WR and WI, say the i-th and (i+1)th, with c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the c eigenvalues are stored in the same order as on the diagonal c of the Schur form returned in H, with WR(i) = H(i,i), and, if c H(i:i+1,i:i+1) is a 2-by-2 diagonal block, c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). c c Z Double precision array, dimension (N). (OUTPUT) c On exit Z contains the last components of the Schur vectors. c c INFO Integer. (OUPUT) c = 0: successful exit c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI c in a total of 30*(IHI-ILO+1) iterations; if INFO = i, c elements i+1:ihi of WR and WI contain those eigenvalues c which have been successfully computed. c c\Remarks c 1. None. c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dlabad LAPACK routine that computes machine constants. c dlamch LAPACK routine that determines machine constants. c dlanhs LAPACK routine that computes various norms of a matrix. c dlanv2 LAPACK routine that computes the Schur factorization of c 2 by 2 nonsymmetric matrix in standard form. c dlarfg LAPACK Householder reflection construction routine. c dcopy Level 1 BLAS that copies one vector to another. c drot Level 1 BLAS that applies a rotation to a 2 by 2 matrix. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c Modified from the LAPACK routine dlahqr so that only the c last component of the Schur vectors are computed. c c\SCCS Information: @(#) c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine dlaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi, & z, info ) c c %------------------% c | Scalar Arguments | c %------------------% c logical wantt integer ihi, ilo, info, ldh, n c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & h( ldh, * ), wi( * ), wr( * ), z( * ) c c %------------% c | Parameters | c %------------% c Double precision & zero, one, dat1, dat2 parameter (zero = 0.0D+0, one = 1.0D+0, dat1 = 7.5D-1, & dat2 = -4.375D-1) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, i1, i2, itn, its, j, k, l, m, nh, nr Double precision & cs, h00, h10, h11, h12, h21, h22, h33, h33s, & h43h34, h44, h44s, ovfl, s, smlnum, sn, sum, & t1, t2, t3, tst1, ulp, unfl, v1, v2, v3 Double precision & v( 3 ), work( 1 ) c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch, dlanhs external dlamch, dlanhs c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dlabad, dlanv2, dlarfg, drot c c %-----------------------% c | Executable Statements | c %-----------------------% c info = 0 c c %--------------------------% c | Quick return if possible | c %--------------------------% c if( n.eq.0 ) & return if( ilo.eq.ihi ) then wr( ilo ) = h( ilo, ilo ) wi( ilo ) = zero return end if c c %---------------------------------------------% c | Initialize the vector of last components of | c | the Schur vectors for accumulation. | c %---------------------------------------------% c do 5 j = 1, n-1 z(j) = zero 5 continue z(n) = one c nh = ihi - ilo + 1 c c %-------------------------------------------------------------% c | Set machine-dependent constants for the stopping criterion. | c | If norm(H) <= sqrt(OVFL), overflow should not occur. | c %-------------------------------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = one / unfl call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( nh / ulp ) c c %---------------------------------------------------------------% c | I1 and I2 are the indices of the first row and last column | c | of H to which transformations must be applied. If eigenvalues | c | only are computed, I1 and I2 are set inside the main loop. | c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | c %---------------------------------------------------------------% c if( wantt ) then i1 = 1 i2 = n do 8 i=1,i2-2 h(i1+i+1,i) = zero 8 continue else do 9 i=1, ihi-ilo-1 h(ilo+i+1,ilo+i-1) = zero 9 continue end if c c %---------------------------------------------------% c | ITN is the total number of QR iterations allowed. | c %---------------------------------------------------% c itn = 30*nh c c ------------------------------------------------------------------ c The main loop begins here. I is the loop index and decreases from c IHI to ILO in steps of 1 or 2. Each iteration of the loop works c with the active submatrix in rows and columns L to I. c Eigenvalues I+1 to IHI have already converged. Either L = ILO or c H(L,L-1) is negligible so that the matrix splits. c ------------------------------------------------------------------ c i = ihi 10 continue l = ilo if( i.lt.ilo ) & go to 150 c %--------------------------------------------------------------% c | Perform QR iterations on rows and columns ILO to I until a | c | submatrix of order 1 or 2 splits off at the bottom because a | c | subdiagonal element has become negligible. | c %--------------------------------------------------------------% do 130 its = 0, itn c c %----------------------------------------------% c | Look for a single small subdiagonal element. | c %----------------------------------------------% c do 20 k = i, l + 1, -1 tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) ) if( tst1.eq.zero ) & tst1 = dlanhs( '1', i-l+1, h( l, l ), ldh, work ) if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) ) & go to 30 20 continue 30 continue l = k if( l.gt.ilo ) then c c %------------------------% c | H(L,L-1) is negligible | c %------------------------% c h( l, l-1 ) = zero end if c c %-------------------------------------------------------------% c | Exit from loop if a submatrix of order 1 or 2 has split off | c %-------------------------------------------------------------% c if( l.ge.i-1 ) & go to 140 c c %---------------------------------------------------------% c | Now the active submatrix is in rows and columns L to I. | c | If eigenvalues only are being computed, only the active | c | submatrix need be transformed. | c %---------------------------------------------------------% c if( .not.wantt ) then i1 = l i2 = i end if c if( its.eq.10 .or. its.eq.20 ) then c c %-------------------% c | Exceptional shift | c %-------------------% c s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) h44 = dat1*s h33 = h44 h43h34 = dat2*s*s c else c c %-----------------------------------------% c | Prepare to use Wilkinson's double shift | c %-----------------------------------------% c h44 = h( i, i ) h33 = h( i-1, i-1 ) h43h34 = h( i, i-1 )*h( i-1, i ) end if c c %-----------------------------------------------------% c | Look for two consecutive small subdiagonal elements | c %-----------------------------------------------------% c do 40 m = i - 2, l, -1 c c %---------------------------------------------------------% c | Determine the effect of starting the double-shift QR | c | iteration at row M, and see if this would make H(M,M-1) | c | negligible. | c %---------------------------------------------------------% c h11 = h( m, m ) h22 = h( m+1, m+1 ) h21 = h( m+1, m ) h12 = h( m, m+1 ) h44s = h44 - h11 h33s = h33 - h11 v1 = ( h33s*h44s-h43h34 ) / h21 + h12 v2 = h22 - h11 - h33s - h44s v3 = h( m+2, m+1 ) s = abs( v1 ) + abs( v2 ) + abs( v3 ) v1 = v1 / s v2 = v2 / s v3 = v3 / s v( 1 ) = v1 v( 2 ) = v2 v( 3 ) = v3 if( m.eq.l ) & go to 50 h00 = h( m-1, m-1 ) h10 = h( m, m-1 ) tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) ) if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 ) & go to 50 40 continue 50 continue c c %----------------------% c | Double-shift QR step | c %----------------------% c do 120 k = m, i - 1 c c ------------------------------------------------------------ c The first iteration of this loop determines a reflection G c from the vector V and applies it from left and right to H, c thus creating a nonzero bulge below the subdiagonal. c c Each subsequent iteration determines a reflection G to c restore the Hessenberg form in the (K-1)th column, and thus c chases the bulge one step toward the bottom of the active c submatrix. NR is the order of G. c ------------------------------------------------------------ c nr = min( 3, i-k+1 ) if( k.gt.m ) & call dcopy( nr, h( k, k-1 ), 1, v, 1 ) call dlarfg( nr, v( 1 ), v( 2 ), 1, t1 ) if( k.gt.m ) then h( k, k-1 ) = v( 1 ) h( k+1, k-1 ) = zero if( k.lt.i-1 ) & h( k+2, k-1 ) = zero else if( m.gt.l ) then h( k, k-1 ) = -h( k, k-1 ) end if v2 = v( 2 ) t2 = t1*v2 if( nr.eq.3 ) then v3 = v( 3 ) t3 = t1*v3 c c %------------------------------------------------% c | Apply G from the left to transform the rows of | c | the matrix in columns K to I2. | c %------------------------------------------------% c do 60 j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 h( k+2, j ) = h( k+2, j ) - sum*t3 60 continue c c %----------------------------------------------------% c | Apply G from the right to transform the columns of | c | the matrix in rows I1 to min(K+3,I). | c %----------------------------------------------------% c do 70 j = i1, min( k+3, i ) sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 h( j, k+2 ) = h( j, k+2 ) - sum*t3 70 continue c c %----------------------------------% c | Accumulate transformations for Z | c %----------------------------------% c sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 ) z( k ) = z( k ) - sum*t1 z( k+1 ) = z( k+1 ) - sum*t2 z( k+2 ) = z( k+2 ) - sum*t3 else if( nr.eq.2 ) then c c %------------------------------------------------% c | Apply G from the left to transform the rows of | c | the matrix in columns K to I2. | c %------------------------------------------------% c do 90 j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 90 continue c c %----------------------------------------------------% c | Apply G from the right to transform the columns of | c | the matrix in rows I1 to min(K+3,I). | c %----------------------------------------------------% c do 100 j = i1, i sum = h( j, k ) + v2*h( j, k+1 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 100 continue c c %----------------------------------% c | Accumulate transformations for Z | c %----------------------------------% c sum = z( k ) + v2*z( k+1 ) z( k ) = z( k ) - sum*t1 z( k+1 ) = z( k+1 ) - sum*t2 end if 120 continue 130 continue c c %-------------------------------------------------------% c | Failure to converge in remaining number of iterations | c %-------------------------------------------------------% c info = i return 140 continue if( l.eq.i ) then c c %------------------------------------------------------% c | H(I,I-1) is negligible: one eigenvalue has converged | c %------------------------------------------------------% c wr( i ) = h( i, i ) wi( i ) = zero else if( l.eq.i-1 ) then c c %--------------------------------------------------------% c | H(I-1,I-2) is negligible; | c | a pair of eigenvalues have converged. | c | | c | Transform the 2-by-2 submatrix to standard Schur form, | c | and compute and store the eigenvalues. | c %--------------------------------------------------------% c call dlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ), & h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ), & cs, sn ) if( wantt ) then c c %-----------------------------------------------------% c | Apply the transformation to the rest of H and to Z, | c | as required. | c %-----------------------------------------------------% c if( i2.gt.i ) & call drot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh, & cs, sn ) call drot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) sum = cs*z( i-1 ) + sn*z( i ) z( i ) = cs*z( i ) - sn*z( i-1 ) z( i-1 ) = sum end if end if c c %---------------------------------------------------------% c | Decrement number of remaining iterations, and return to | c | start of the main loop with new value of I. | c %---------------------------------------------------------% c itn = itn - its i = l - 1 go to 10 150 continue return c c %---------------% c | End of dlaqrb | c %---------------% c end arpack-akloeckner-07/SRC/dnaitr.f0000644000175000017500000007367310670622032016570 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dnaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step nonsymmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in dnaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call dnaitr c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and do not need to be c recompute in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. See dnaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current size of V and H. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c NB Integer. (INPUT) c Blocksize to be used in the recurrence. c Only work for NB = 1 right now. The goal is to have a c program that implement both the block and non-block method. c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Double precision scalar. (INPUT/OUTPUT) c B-norm of the starting residual on input. c B-norm of the updated residual r_{k+p} on output. c c V Double precision N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (K+NP) by (K+NP) array. (INPUT/OUTPUT) c H is used to store the generated upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On input, WORKD(1:N) = B*RESID and is used to save some c computation at the first step. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of the spanning invariant subspace of OP found. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c dgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c dmout ARPACK utility routine that prints matrices c dvout ARPACK utility routine that prints vectors. c dlabad LAPACK routine that computes machine constants. c dlamch LAPACK routine that determines machine constants. c dlascl LAPACK routine for careful scaling of a matrix. c dlanhs LAPACK routine that computes various norms of a matrix. c dgemv Level 2 BLAS routine for matrix vector multiplication. c daxpy Level 1 BLAS that computes a vector triad. c dscal Level 1 BLAS that scales a vector. c dcopy Level 1 BLAS that copies one vector to another . c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c ( At present tol is zero ) c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in dnaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c H(:,j) = w_{j}; c H(j,j-1) = rnorm c rnorm = || r_(j) || c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine dnaitr & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, nb, np Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Double precision & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, & jj Double precision & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, & wnorm save first, orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, & betaj, rnorm1, smlnum, ulp, unfl, wnorm c c %-----------------------% c | Local Array Arguments | c %-----------------------% c Double precision & xtemp(2) c c %----------------------% c | External Subroutines | c %----------------------% c external daxpy, dcopy, dscal, dgemv, dgetv0, dlabad, & dvout, dmout, ivout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2, dlanhs, dlamch external ddot, dnrm2, dlanhs, dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, sqrt c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------% c | Set machine-dependent constants for the | c | the splitting and deflation criterion. | c | If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine dlahqr | c %-----------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = one / unfl call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mnaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. j = k + 1 ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. when .... | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | dgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %-----------------------------% c | Else this is the first step | c %-----------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% 1000 continue c if (msglvl .gt. 1) then call ivout (logfil, 1, j, ndigit, & '_naitr: generating Arnoldi vector number') call dvout (logfil, 1, rnorm, ndigit, & '_naitr: B-norm of the current residual is') end if c c %---------------------------------------------------% c | STEP 1: Check if the B norm of j-th residual | c | vector is zero. Equivalent to determing whether | c | an exact j-step Arnoldi factorization is present. | c %---------------------------------------------------% c betaj = rnorm if (rnorm .gt. zero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: ****** RESTART AT STEP ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c betaj = zero nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call arscnd (t1) tnaitr = tnaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call dcopy (n, resid, 1, v(1,j), 1) if (rnorm .ge. unfl) then temp1 = one / rnorm call dscal (n, temp1, v(1,j), 1) call dscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine SLASCL | c %-----------------------------------------% c call dlascl ('General', i, i, rnorm, one, n, 1, & v(1,j), n, infol) call dlascl ('General', i, i, rnorm, one, n, 1, & workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call arscnd (t2) call dcopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | c | if step3 = .true. | c %----------------------------------% c call arscnd (t3) tmvopx = tmvopx + (t3 - t2) step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call dcopy (n, workd(irj), 1, resid, 1) c c %---------------------------------------% c | STEP 4: Finish extending the Arnoldi | c | factorization to length j. | c %---------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 60 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | c | if step4 = .true. | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c if (bmat .eq. 'G') then wnorm = ddot (n, resid, 1, workd(ipj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'I') then wnorm = dnrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, h(1,j), 1) c c %--------------------------------------% c | Orthogonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call dgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c if (j .gt. 1) h(j,j-1) = betaj c call arscnd (t4) c orth1 = .true. c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd(ipj), 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c | The following test determines whether the sine of the | c | angle between OP*x and the computed residual is less | c | than or equal to 0.717. | c %-----------------------------------------------------------% c if (rnorm .gt. 0.717*wnorm) go to 100 iter = 0 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then xtemp(1) = wnorm xtemp(2) = rnorm call dvout (logfil, 2, xtemp, ndigit, & '_naitr: re-orthonalization; wnorm and rnorm are') call dvout (logfil, j, h(1,j), ndigit, & '_naitr: j-th column of H') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %---------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) | c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | c %---------------------------------------------% c call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) call daxpy (j, one, workd(irj), 1, h(1,j), 1) c orth2 = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then rnorm1 = ddot (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt(abs(rnorm1)) else if (bmat .eq. 'I') then rnorm1 = dnrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then xtemp(1) = rnorm xtemp(2) = rnorm1 call dvout (logfil, 2, xtemp, ndigit, & '_naitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if (rnorm1 .gt. 0.717*rnorm) then c c %---------------------------------------% c | No need for further refinement. | c | The cosine of the angle between the | c | corrected residual vector and the old | c | residual vector is greater than 0.717 | c | In other words the corrected residual | c | and the old residual vector share an | c | angle of less than arcCOS(0.717) | c %---------------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = zero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call arscnd (t5) titref = titref + (t5 - t4) c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call arscnd (t1) tnaitr = tnaitr + (t1 - t0) ido = 99 do 110 i = max(1,k), k+np-1 c c %--------------------------------------------% c | Check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine dlahqr | c %--------------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = dlanhs( '1', k+np, h, ldh, workd(n+1) ) if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue c if (msglvl .gt. 2) then call dmout (logfil, k+np, k+np, h, ldh, ndigit, & '_naitr: Final upper Hessenberg matrix H of order K+NP') end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of dnaitr | c %---------------% c end arpack-akloeckner-07/SRC/dnapps.f0000644000175000017500000005572110670622032016566 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dnapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP implicit shifts resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix which is the product of rotations c and reflections resulting from the NP bulge chage sweeps. c The updated Arnoldi factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call dnapps c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, c WORKL, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. size of matrix A. c c KEV Integer. (INPUT/OUTPUT) c KEV+NP is the size of the input matrix H. c KEV is the size of the updated matrix HNEW. KEV is only c updated on ouput when fewer than NP shifts are applied in c order to keep the conjugate pair together. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFTR, Double precision array of length NP. (INPUT) c SHIFTI Real and imaginary part of the shifts to be applied. c Upon, entry to dnapps, the shifts must be sorted so that the c conjugate pairs are in consecutive locations. c c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, V contains the current KEV+NP Arnoldi vectors. c On OUTPUT, V contains the updated KEV Arnoldi vectors c in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, H contains the current KEV+NP by KEV+NP upper c Hessenber matrix of the Arnoldi factorization. c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg c matrix in the KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT, RESID contains the the residual vector r_{k+p}. c On OUTPUT, RESID is the update residual vector rnew_{k} c in the first KEV locations. c c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations and reflections c during the bulge chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Double precision work array of length (KEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c WORKD Double precision work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c dmout ARPACK utility routine that prints matrices. c dvout ARPACK utility routine that prints vectors. c dlabad LAPACK routine that computes machine constants. c dlacpy LAPACK matrix copy routine. c dlamch LAPACK routine that determines machine constants. c dlanhs LAPACK routine that computes various norms of a matrix. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlarf LAPACK routine that applies Householder reflection to c a matrix. c dlarfg LAPACK Householder reflection construction routine. c dlartg LAPACK Givens rotation construction routine. c dlaset LAPACK matrix initialization routine. c dgemv Level 2 BLAS routine for matrix vector multiplication. c daxpy Level 1 BLAS that computes a vector triad. c dcopy Level 1 BLAS that copies one vector to another . c dscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the sublocks of c the Hessenberg matrix H and not just to the submatrix that it c comes from. Deflation as in LAPACK routine dlahqr (QR algorithm c for upper Hessenberg matrices ) is used. c The subdiagonals of H are enforced to be non-negative. c c\EndLib c c----------------------------------------------------------------------- c subroutine dnapps & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, & workl, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr logical cconj, first Double precision & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 save first, ovfl, smlnum, ulp, unfl c c %----------------------% c | External Subroutines | c %----------------------% c external daxpy, dcopy, dscal, dlacpy, dlarfg, dlarf, & dlaset, dlabad, arscnd, dlartg c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch, dlanhs, dlapy2 external dlamch, dlanhs, dlapy2 c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs, max, min c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------------% c | Set machine-dependent constants for the | c | stopping criterion. If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine dlahqr | c %-----------------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = one / unfl call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mnapps kplusp = kev + np c c %--------------------------------------------% c | Initialize Q to the identity to accumulate | c | the rotations and reflections | c %--------------------------------------------% c call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------% c | Chase the bulge with the application of each | c | implicit shift. Each shift is applied to the | c | whole matrix including each block. | c %----------------------------------------------% c cconj = .false. do 110 jj = 1, np sigmar = shiftr(jj) sigmai = shifti(jj) c if (msglvl .gt. 2 ) then call ivout (logfil, 1, jj, ndigit, & '_napps: shift number.') call dvout (logfil, 1, sigmar, ndigit, & '_napps: The real part of the shift ') call dvout (logfil, 1, sigmai, ndigit, & '_napps: The imaginary part of the shift ') end if c c %-------------------------------------------------% c | The following set of conditionals is necessary | c | in order that complex conjugate pairs of shifts | c | are applied together or not at all. | c %-------------------------------------------------% c if ( cconj ) then c c %-----------------------------------------% c | cconj = .true. means the previous shift | c | had non-zero imaginary part. | c %-----------------------------------------% c cconj = .false. go to 110 else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then c c %------------------------------------% c | Start of a complex conjugate pair. | c %------------------------------------% c cconj = .true. else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then c c %----------------------------------------------% c | The last shift has a nonzero imaginary part. | c | Don't apply it; thus the order of the | c | compressed H is order KEV+1 since only np-1 | c | were applied. | c %----------------------------------------------% c kev = kev + 1 go to 110 end if istart = 1 20 continue c c %--------------------------------------------------% c | if sigmai = 0 then | c | Apply the jj-th shift ... | c | else | c | Apply the jj-th and (jj+1)-th together ... | c | (Note that jj < np at this point in the code) | c | end | c | to the current block of H. The next do loop | c | determines the current block ; | c %--------------------------------------------------% c do 30 i = istart, kplusp-1 c c %----------------------------------------% c | Check for splitting and deflation. Use | c | a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine dlahqr | c %----------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = dlanhs( '1', kplusp-jj+1, h, ldh, workl ) if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_napps: matrix splitting at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_napps: matrix splitting with shift number.') call dvout (logfil, 1, h(i+1,i), ndigit, & '_napps: off diagonal element.') end if iend = i h(i+1,i) = zero go to 40 end if 30 continue iend = kplusp 40 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, istart, ndigit, & '_napps: Start of current block ') call ivout (logfil, 1, iend, ndigit, & '_napps: End of current block ') end if c c %------------------------------------------------% c | No reason to apply a shift to block of order 1 | c %------------------------------------------------% c if ( istart .eq. iend ) go to 100 c c %------------------------------------------------------% c | If istart + 1 = iend then no reason to apply a | c | complex conjugate pair of shifts on a 2 by 2 matrix. | c %------------------------------------------------------% c if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) & go to 100 c h11 = h(istart,istart) h21 = h(istart+1,istart) if ( abs( sigmai ) .le. zero ) then c c %---------------------------------------------% c | Real-valued shift ==> apply single shift QR | c %---------------------------------------------% c f = h11 - sigmar g = h21 c do 80 i = istart, iend-1 c c %-----------------------------------------------------% c | Contruct the plane rotation G to zero out the bulge | c %-----------------------------------------------------% c call dlartg (f, g, c, s, r) if (i .gt. istart) then c c %-------------------------------------------% c | The following ensures that h(1:iend-1,1), | c | the first iend-2 off diagonal of elements | c | H, remain non negative. | c %-------------------------------------------% c if (r .lt. zero) then r = -r c = -c s = -s end if h(i,i-1) = r h(i+1,i-1) = zero end if c c %---------------------------------------------% c | Apply rotation to the left of H; H <- G'*H | c %---------------------------------------------% c do 50 j = i, kplusp t = c*h(i,j) + s*h(i+1,j) h(i+1,j) = -s*h(i,j) + c*h(i+1,j) h(i,j) = t 50 continue c c %---------------------------------------------% c | Apply rotation to the right of H; H <- H*G | c %---------------------------------------------% c do 60 j = 1, min(i+2,iend) t = c*h(j,i) + s*h(j,i+1) h(j,i+1) = -s*h(j,i) + c*h(j,i+1) h(j,i) = t 60 continue c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 70 j = 1, min( i+jj, kplusp ) t = c*q(j,i) + s*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = t 70 continue c c %---------------------------% c | Prepare for next rotation | c %---------------------------% c if (i .lt. iend-1) then f = h(i+1,i) g = h(i+2,i) end if 80 continue c c %-----------------------------------% c | Finished applying the real shift. | c %-----------------------------------% c else c c %----------------------------------------------------% c | Complex conjugate shifts ==> apply double shift QR | c %----------------------------------------------------% c h12 = h(istart,istart+1) h22 = h(istart+1,istart+1) h32 = h(istart+2,istart+1) c c %---------------------------------------------------------% c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | c %---------------------------------------------------------% c s = 2.0*sigmar t = dlapy2 ( sigmar, sigmai ) u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 u(2) = h11 + h22 - s u(3) = h32 c do 90 i = istart, iend-1 c nr = min ( 3, iend-i+1 ) c c %-----------------------------------------------------% c | Construct Householder reflector G to zero out u(1). | c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | c %-----------------------------------------------------% c call dlarfg ( nr, u(1), u(2), 1, tau ) c if (i .gt. istart) then h(i,i-1) = u(1) h(i+1,i-1) = zero if (i .lt. iend-1) h(i+2,i-1) = zero end if u(1) = one c c %--------------------------------------% c | Apply the reflector to the left of H | c %--------------------------------------% c call dlarf ('Left', nr, kplusp-i+1, u, 1, tau, & h(i,i), ldh, workl) c c %---------------------------------------% c | Apply the reflector to the right of H | c %---------------------------------------% c ir = min ( i+3, iend ) call dlarf ('Right', ir, nr, u, 1, tau, & h(1,i), ldh, workl) c c %-----------------------------------------------------% c | Accumulate the reflector in the matrix Q; Q <- Q*G | c %-----------------------------------------------------% c call dlarf ('Right', kplusp, nr, u, 1, tau, & q(1,i), ldq, workl) c c %----------------------------% c | Prepare for next reflector | c %----------------------------% c if (i .lt. iend-1) then u(1) = h(i+1,i) u(2) = h(i+2,i) if (i .lt. iend-2) u(3) = h(i+3,i) end if c 90 continue c c %--------------------------------------------% c | Finished applying a complex pair of shifts | c | to the current block | c %--------------------------------------------% c end if c 100 continue c c %---------------------------------------------------------% c | Apply the same shift to the next block if there is any. | c %---------------------------------------------------------% c istart = iend + 1 if (iend .lt. kplusp) go to 20 c c %---------------------------------------------% c | Loop back to the top to get the next shift. | c %---------------------------------------------% c 110 continue c c %--------------------------------------------------% c | Perform a similarity transformation that makes | c | sure that H will have non negative sub diagonals | c %--------------------------------------------------% c do 120 j=1,kev if ( h(j+1,j) .lt. zero ) then call dscal( kplusp-j+1, -one, h(j+1,j), ldh ) call dscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) call dscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) end if 120 continue c do 130 i = 1, kev c c %--------------------------------------------% c | Final check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine dlahqr | c %--------------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = dlanhs( '1', kev, h, ldh, workl ) if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 130 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is needed in the residual update since we | c | cannot GUARANTEE that the corresponding entry | c | of H would be zero as in exact arithmetic. | c %-------------------------------------------------% c if (h(kev+1,kev) .gt. zero) & call dgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, & workd(n+1), 1) c c %----------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage of the upper Hessenberg structure of Q. | c %----------------------------------------------------------% c do 140 i = 1, kev call dgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) 140 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call dlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) c c %--------------------------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | c %--------------------------------------------------------------% c if (h(kev+1,kev) .gt. zero) & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kplusp}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call dscal (n, q(kplusp,kev), resid, 1) if (h(kev+1,kev) .gt. zero) & call daxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call dvout (logfil, 1, q(kplusp,kev), ndigit, & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') call dvout (logfil, 1, h(kev+1,kev), ndigit, & '_napps: betak = e_{kev+1}^T*H*e_{kev}') call ivout (logfil, 1, kev, ndigit, & '_napps: Order of the final Hessenberg matrix ') if (msglvl .gt. 2) then call dmout (logfil, kev, kev, h, ldh, ndigit, & '_napps: updated Hessenberg matrix H for next iteration') end if c end if c 9000 continue call arscnd (t1) tnapps = tnapps + (t1 - t0) c return c c %---------------% c | End of dnapps | c %---------------% c end arpack-akloeckner-07/SRC/dnaup2.f0000644000175000017500000007536510670622032016500 0ustar andreasandreasc\BeginDoc c c\Name: dnaup2 c c\Description: c Intermediate level interface called by dnaupd. c c\Usage: c call dnaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dnaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in dnaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV for two reasons. The first, is c to keep complex conjugate pairs of "wanted" Ritz values c together. The second, is that a leading block of the current c upper Hessenberg matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) c The Arnoldi basis vectors are returned in the first NEV c columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (NEV+NP) by (NEV+NP) array. (OUTPUT) c H is used to store the generated upper Hessenberg matrix c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZR, Double precision arrays of length NEV+NP. (OUTPUT) c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. c imaginary) part of the computed Ritz values of OP. c c BOUNDS Double precision array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to c the computed Ritz values. c c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Double precision work array of length at least c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in shifts calculation, shifts c application and convergence checking. c c On exit, the last 3*(NEV+NP) locations of WORKL contain c the Ritz values (real,imaginary) and associated Ritz c estimates of the current Hessenberg matrix. They are c listed in the same order as returned from dneigh. c c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations c of WORKL are used in reverse communication to hold the user c supplied shifts. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (WORKSPACE) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in DNAUPD. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. c NP returns the number of converged Ritz values. c = 2: No shifts could be applied. c = -8: Error return from LAPACK eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Arnoldi factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c dgetv0 ARPACK initial vector generation routine. c dnaitr ARPACK Arnoldi factorization routine. c dnapps ARPACK application of implicit shifts routine. c dnconv ARPACK convergence of Ritz values routine. c dneigh ARPACK compute Ritz values and error bounds routine. c dngets ARPACK reorder Ritz values and error bounds routine. c dsortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c dmout ARPACK utility routine that prints matrices c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dcopy Level 1 BLAS that copies one vector to another . c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dswap Level 1 BLAS that swaps two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine dnaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ipntr, workd, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, & n, nev, np Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(13) Double precision & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), & workd(3*n), workl( (nev+np)*(nev+np+3) ) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c character wprime*2 logical cnorm , getv0, initv, update, ushift integer ierr , iter , j , kplusp, msglvl, nconv, & nevbef, nev0 , np0 , nptemp, numcnv Double precision & rnorm , temp , eps23 save cnorm , getv0, initv, update, ushift, & rnorm , iter , eps23, kplusp, msglvl, nconv , & nevbef, nev0 , np0 , numcnv c c %-----------------------% c | Local array arguments | c %-----------------------% c integer kp(4) c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy , dgetv0, dnaitr, dnconv, dneigh, & dngets, dnapps, dvout , ivout , arscnd c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2, dlapy2, dlamch external ddot, dnrm2, dlapy2, dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min, max, abs, sqrt c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c call arscnd (t0) c msglvl = mnaup2 c c %-------------------------------------% c | Get the machine dependent constant. | c %-------------------------------------% c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0) c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvlues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev + np nconv = 0 iter = 0 c c %---------------------------------------% c | Set flags for computing the first NEV | c | steps of the Arnoldi factorization. | c %---------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. zero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1100 end if getv0 = .false. ido = 0 end if c c %-----------------------------------% c | Back from reverse communication : | c | continue with update step | c %-----------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Arnoldi factorization | c %----------------------------------------------------------% c call dnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N ARNOLDI I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Arnoldi | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_naup2: **** Start of major iteration number ****') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c | Adjust NP since NEV might have been updated by last call | c | to the shift application routine dnapps. | c %-----------------------------------------------------------% c np = kplusp - nev c if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_naup2: The length of the current Arnoldi factorization') call ivout (logfil, 1, np, ndigit, & '_naup2: Extend the Arnoldi factorization by') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c %-----------------------------------------------------------% c ido = 0 20 continue update = .true. c call dnaitr (ido , bmat, n , nev, np , mode , resid, & rnorm, v , ldv, h , ldh, ipntr, workd, & info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call dvout (logfil, 1, rnorm, ndigit, & '_naup2: Corresponding B-norm of the residual') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current upper Hessenberg matrix. | c %--------------------------------------------------------% c call dneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %----------------------------------------------------% c | Make a copy of eigenvalues and corresponding error | c | bounds obtained from dneigh. | c %----------------------------------------------------% c call dcopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1) call dcopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) call dcopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | error bounds are in the last NEV loc. of RITZR, | c | RITZI and BOUNDS respectively. The variables NEV | c | and NP may be updated if the NEV-th wanted Ritz | c | value has a non zero imaginary part. In this case | c | NEV is increased by one and NP decreased by one. | c | NOTE: The last two arguments of dngets are no | c | longer used as of version 2.1. | c %---------------------------------------------------% c nev = nev0 np = np0 numcnv = nev call dngets (ishift, which, nev, np, ritzr, ritzi, & bounds, workl, workl(np+1)) if (nev .eq. nev0+1) numcnv = nev0+1 c c %-------------------% c | Convergence test. | c %-------------------% c call dcopy (nev, bounds(np+1), 1, workl(2*np+1), 1) call dnconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), & tol, nconv) c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = numcnv kp(4) = nconv call ivout (logfil, 4, kp, ndigit, & '_naup2: NEV, NP, NUMCNV, NCONV are') call dvout (logfil, kplusp, ritzr, ndigit, & '_naup2: Real part of the eigenvalues of H') call dvout (logfil, kplusp, ritzi, ndigit, & '_naup2: Imaginary part of the eigenvalues of H') call dvout (logfil, kplusp, bounds, ndigit, & '_naup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. numcnv) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c if (msglvl .gt. 4) then call dvout(logfil, kplusp, workl(kplusp**2+1), ndigit, & '_naup2: Real part of the eig computed by _neigh:') call dvout(logfil, kplusp, workl(kplusp**2+kplusp+1), & ndigit, & '_naup2: Imag part of the eig computed by _neigh:') call dvout(logfil, kplusp, workl(kplusp**2+kplusp*2+1), & ndigit, & '_naup2: Ritz eistmates computed by _neigh:') end if c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP | c %------------------------------------------------% c c %------------------------------------------% c | Use h( 3,1 ) as storage to communicate | c | rnorm to _neupd if needed | c %------------------------------------------% h(3,1) = rnorm c c %----------------------------------------------% c | To be consistent with dngets, we first do a | c | pre-processing sort in order to keep complex | c | conjugate pairs together. This is similar | c | to the pre-processing sort used in dngets | c | except that the sort is done in the opposite | c | order. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SR' if (which .eq. 'SM') wprime = 'LR' if (which .eq. 'LR') wprime = 'SM' if (which .eq. 'SR') wprime = 'LM' if (which .eq. 'LI') wprime = 'SM' if (which .eq. 'SI') wprime = 'LM' c call dsortc (wprime, .true., kplusp, ritzr, ritzi, bounds) c c %----------------------------------------------% c | Now sort Ritz values so that converged Ritz | c | values appear within the first NEV locations | c | of ritzr, ritzi and bounds, and the most | c | desired one appears at the front. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LR') wprime = 'SR' if (which .eq. 'SR') wprime = 'LR' if (which .eq. 'LI') wprime = 'SI' if (which .eq. 'SI') wprime = 'LI' c call dsortc(wprime, .true., kplusp, ritzr, ritzi, bounds) c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23,magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, numcnv temp = max(eps23,dlapy2(ritzr(j), & ritzi(j))) bounds(j) = bounds(j)/temp 35 continue c c %----------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | esitmates. This will push all the converged ones | c | towards the front of ritzr, ritzi, bounds | c | (in the case when NCONV < NEV.) | c %----------------------------------------------------% c wprime = 'LR' call dsortc(wprime, .true., numcnv, bounds, ritzr, ritzi) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, numcnv temp = max(eps23, dlapy2(ritzr(j), & ritzi(j))) bounds(j) = bounds(j)*temp 40 continue c c %------------------------------------------------% c | Sort the converged Ritz values again so that | c | the "threshold" value appears at the front of | c | ritzr, ritzi and bound. | c %------------------------------------------------% c call dsortc(which, .true., nconv, ritzr, ritzi, bounds) c if (msglvl .gt. 1) then call dvout (logfil, kplusp, ritzr, ndigit, & '_naup2: Sorted real part of the eigenvalues') call dvout (logfil, kplusp, ritzi, ndigit, & '_naup2: Sorted imaginary part of the eigenvalues') call dvout (logfil, kplusp, bounds, ndigit, & '_naup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 c np = nconv go to 1100 c else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then c c %-------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the size | c | of NEV. | c %-------------------------------------------------% c nevbef = nev nev = nev + min(nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 3) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call dngets (ishift, which, nev, np, ritzr, ritzi, & bounds, workl, workl(np+1)) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_naup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_naup2: NEV and NP are') call dvout (logfil, nev, ritzr(np+1), ndigit, & '_naup2: "wanted" Ritz values -- real part') call dvout (logfil, nev, ritzi(np+1), ndigit, & '_naup2: "wanted" Ritz values -- imag part') call dvout (logfil, nev, bounds(np+1), ndigit, & '_naup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-------------------------------------------------------% c | User specified shifts: reverse comminucation to | c | compute the shifts. They are returned in the first | c | 2*NP locations of WORKL. | c %-------------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if c 50 continue c c %------------------------------------% c | Back from reverse communication; | c | User specified shifts are returned | c | in WORKL(1:2*NP) | c %------------------------------------% c ushift = .false. c if ( ishift .eq. 0 ) then c c %----------------------------------% c | Move the NP shifts from WORKL to | c | RITZR, RITZI to free up WORKL | c | for non-exact shift case. | c %----------------------------------% c call dcopy (np, workl, 1, ritzr, 1) call dcopy (np, workl(np+1), 1, ritzi, 1) end if c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_naup2: The number of shifts to apply ') call dvout (logfil, np, ritzr, ndigit, & '_naup2: Real part of the shifts') call dvout (logfil, np, ritzi, ndigit, & '_naup2: Imaginary part of the shifts') if ( ishift .eq. 1 ) & call dvout (logfil, np, bounds, ndigit, & '_naup2: Ritz estimates of the shifts') end if c c %---------------------------------------------------------% c | Apply the NP implicit shifts by QR bulge chasing. | c | Each shift is applied to the whole upper Hessenberg | c | matrix H. | c | The first 2*N locations of WORKD are used as workspace. | c %---------------------------------------------------------% c call dnapps (n, nev, np, ritzr, ritzi, v, ldv, & h, ldh, resid, q, ldq, workl, workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to dnaitr. | c %---------------------------------------------% c cnorm = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if cnorm = .false. c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm, ndigit, & '_naup2: B-norm of residual for compressed factorization') call dmout (logfil, nev, nev, h, ldh, ndigit, & '_naup2: Compressed upper Hessenberg matrix H') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = numcnv c 1200 continue ido = 99 c c %------------% c | Error Exit | c %------------% c call arscnd (t1) tnaup2 = t1 - t0 c 9000 continue c c %---------------% c | End of dnaup2 | c %---------------% c return end arpack-akloeckner-07/SRC/dnaupd.f0000644000175000017500000007202310670622032016546 0ustar andreasandreasc\BeginDoc c c\Name: dnaupd c c\Description: c Reverse communication interface for the Implicitly Restarted Arnoldi c iteration. This subroutine computes approximations to a few eigenpairs c of a linear operator "OP" with respect to a semi-inner product defined by c a symmetric positive semi-definite real matrix B. B may be the identity c matrix. NOTE: If the linear operator "OP" is real and symmetric c with respect to the real positive semi-definite symmetric matrix B, c i.e. B*OP = (OP`)*B, then subroutine dsaupd should be used instead. c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c dnaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x. c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: A*x = lambda*M*x, M symmetric semi-definite c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*x = amu*x, then c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. c Note: If sigma is real, i.e. imaginary part of sigma is zero; c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M c amu == 1/(lambda-sigma). c c Mode 4: A*x = lambda*M*x, M symmetric semi-definite c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*x = amu*x, then c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. c c Both mode 3 and 4 give the same enhancement to eigenvalues close to c the (complex) shift sigma. However, as lambda goes to infinity, c the operator OP in mode 4 dampens the eigenvalues more strongly than c does OP defined in mode 3. c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call dnaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to dnaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c dnaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3 and 4, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute the IPARAM(8) real and imaginary parts c of the shifts where INPTR(14) is the pointer c into WORKL for placing the shifts. See Remark c 5 below. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c NEV Integer. (INPUT/OUTPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. c c TOL Double precision scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = DLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine DLAMCH). c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 2 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz c values are kept together. (See remark 4 below) c c V Double precision array N by NCV. (OUTPUT) c Contains the final set of Arnoldi basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are provided by the user via c reverse communication. The real and imaginary c parts of the NCV eigenvalues of the Hessenberg c matrix H are returned in the part of the WORKL c array corresponding to RITZR and RITZI. See remark c 5 below. c ISHIFT = 1: exact shifts with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of approximate Schur c vectors associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced. c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4; See under \Description of dnaupd for the c four modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), dnaupd returns NP, the number c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark c 5 below. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 14. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix c H in WORKL. c IPNTR(6): pointer to the real part of the ritz value array c RITZR in WORKL. c IPNTR(7): pointer to the imaginary part of the ritz value array c RITZI in WORKL. c IPNTR(8): pointer to the Ritz estimates in array WORKL associated c with the Ritz values located in RITZR and RITZI in WORKL. c c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. c c Note: IPNTR(9:13) is only referenced by dneupd. See Remark 2 below. c c IPNTR(9): pointer to the real part of the NCV RITZ values of the c original system. c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of c the original system. c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c dneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration. Upon termination c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace c associated with the converged Ritz values is desired, see remark c 2 below, subroutine dneupd uses this output. c See Data Distribution Note below. c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 6*NCV. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -4: The maximum number of Arnoldi update iteration c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation; c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. c = -12: IPARAM(1) must be equal to 0 or 1. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current Arnoldi c factorization. c c\Remarks c 1. The computed Ritz values are approximate eigenvalues of OP. The c selection of WHICH should be made with this in mind when c Mode = 3 and 4. After convergence, approximate eigenvalues of the c original problem may be obtained with the ARPACK subroutine dneupd. c c 2. If a basis for the invariant subspace corresponding to the converged Ritz c values is needed, the user must call dneupd immediately following c completion of dnaupd. This is new starting with release 2 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2. c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c See Chapter 8 of Reference 2 for further information. c c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) real and imaginary parts of the shifts in locations c real part imaginary part c ----------------------- -------------- c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) c . . c . . c . . c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). c c Only complex conjugate pairs of shifts may be applied and the pairs c must be placed in consecutive locations. The real part of the c eigenvalues of the current upper Hessenberg matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered c according to the order defined by WHICH. The complex conjugate c pairs are kept together and the associated Ritz estimates are located in c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c Double precision resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c decompose d1(n), d2(n,ncv) c align resid(i) with d1(i) c align v(i,j) with d2(i,j) c align workd(i) with d1(i) range (1:n) c align workd(i) with d1(i-n) range (n+1:2*n) c align workd(i) with d1(i-2*n) range (2*n+1:3*n) c distribute d1(block), d2(block,:) c replicated workl(lworkl) c c Cray MPP syntax: c =============== c Double precision resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) c shared resid(block), v(block,:), workd(block,:) c replicated workl(lworkl) c c CM2/CM5 syntax: c ============== c c----------------------------------------------------------------------- c c include 'ex-nonsym.doc' c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c dnaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version '1.1' c c\SCCS Information: @(#) c FILE: naupd.F SID: 2.10 DATE OF SID: 08/23/02 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine dnaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) Double precision & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritzi, ritzr, j save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, & levec, mode, msglvl, mxiter, nb, nev0, next, & np, ritzi, ritzr c c %----------------------% c | External Subroutines | c %----------------------% c external dnaup2, dvout, ivout, arscnd, dstatn c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch external dlamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call dstatn call arscnd (t0) msglvl = mnaupd c c %----------------% c | Error checking | c %----------------% c ierr = 0 ishift = iparam(1) c levec = iparam(2) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev+1 .or. ncv .gt. n) then ierr = -3 else if (mxiter .le. 0) then ierr = 4 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 6*ncv) then ierr = -7 else if (mode .lt. 1 .or. mode .gt. 4) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 else if (ishift .lt. 0 .or. ishift .gt. 1) then ierr = -12 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. zero) tol = dlamch('EpsMach') c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, 3*ncv**2 + 6*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | c | parts of ritz values | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | c | The final workspace is needed by subroutine dneigh called | c | by dnaup2. Subroutine dneigh calls LAPACK routines for | c | calculating eigenvalues and the last row of the eigenvector | c | matrix. | c %-------------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritzr = ih + ldh*ncv ritzi = ritzr + ncv bounds = ritzi + ncv iq = bounds + ncv iw = iq + ldq*ncv next = iw + ncv**2 + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritzr ipntr(7) = ritzi ipntr(8) = bounds ipntr(14) = iw c end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Arnoldi Iteration. | c %-------------------------------------------------------% c call dnaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), & ipntr, workd, info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP or shifts. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within dnaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_naupd: Number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_naupd: Number of wanted "converged" Ritz values') call dvout (logfil, np, workl(ritzr), ndigit, & '_naupd: Real part of the final Ritz values') call dvout (logfil, np, workl(ritzi), ndigit, & '_naupd: Imaginary part of the final Ritz values') call dvout (logfil, np, workl(bounds), ndigit, & '_naupd: Associated Ritz estimates') end if c call arscnd (t1) tnaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, & tgetv0, tneigh, tngets, tnapps, tnconv, trvec 1000 format (//, & 5x, '=============================================',/ & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ & 5x, '= Version Number: ', ' 2.4', 21x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ & 5x, '=============================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '=============================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in naup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6,/ & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) end if c 9000 continue c return c c %---------------% c | End of dnaupd | c %---------------% c end arpack-akloeckner-07/SRC/dnconv.f0000644000175000017500000000776510670622032016575 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dnconv c c\Description: c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. c c\Usage: c call dnconv c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) c c\Arguments c N Integer. (INPUT) c Number of Ritz values to check for convergence. c c RITZR, Double precision arrays of length N. (INPUT) c RITZI Real and imaginary parts of the Ritz values to be checked c for convergence. c BOUNDS Double precision array of length N. (INPUT) c Ritz estimates for the Ritz values in RITZR and RITZI. c c TOL Double precision scalar. (INPUT) c Desired backward error for a Ritz value to be considered c "converged". c c NCONV Integer scalar. (OUTPUT) c Number of "converged" Ritz values. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c arscnd ARPACK utility routine for timing. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. xxxx c c\EndLib c c----------------------------------------------------------------------- c subroutine dnconv (n, ritzr, ritzi, bounds, tol, nconv) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer n, nconv Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% Double precision & ritzr(n), ritzi(n), bounds(n) c c %---------------% c | Local Scalars | c %---------------% c integer i Double precision & temp, eps23 c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlapy2, dlamch external dlapy2, dlamch c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------------------% c | Convergence test: unlike in the symmetric code, I am not | c | using things like refined error bounds and gap condition | c | because I don't know the exact equivalent concept. | c | | c | Instead the i-th Ritz value is considered "converged" when: | c | | c | bounds(i) .le. ( TOL * | ritz | ) | c | | c | for some appropriate choice of norm. | c %-------------------------------------------------------------% c call arscnd (t0) c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0) c nconv = 0 do 20 i = 1, n temp = max( eps23, dlapy2( ritzr(i), ritzi(i) ) ) if (bounds(i) .le. tol*temp) nconv = nconv + 1 20 continue c call arscnd (t1) tnconv = tnconv + (t1 - t0) c return c c %---------------% c | End of dnconv | c %---------------% c end arpack-akloeckner-07/SRC/dneigh.f0000644000175000017500000002424110670622032016530 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dneigh c c\Description: c Compute the eigenvalues of the current upper Hessenberg matrix c and the corresponding Ritz estimates given the current residual norm. c c\Usage: c call dneigh c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) c c\Arguments c RNORM Double precision scalar. (INPUT) c Residual norm corresponding to the current upper Hessenberg c matrix H. c c N Integer. (INPUT) c Size of the matrix H. c c H Double precision N by N array. (INPUT) c H contains the current upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZR, Double precision arrays of length N. (OUTPUT) c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real c (respectively imaginary) parts of the eigenvalues of H. c c BOUNDS Double precision array of length N. (OUTPUT) c On output, BOUNDS contains the Ritz estimates associated with c the eigenvalues RITZR and RITZI. This is equal to RNORM c times the last components of the eigenvectors corresponding c to the eigenvalues in RITZR and RITZI. c c Q Double precision N by N array. (WORKSPACE) c Workspace needed to store the eigenvectors of H. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Double precision work array of length N**2 + 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. This is needed to keep the full Schur form c of H and also in the calculation of the eigenvectors of H. c c IERR Integer. (OUTPUT) c Error exit flag from dlaqrb or dtrevc. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dlaqrb ARPACK routine to compute the real Schur form of an c upper Hessenberg matrix and last row of the Schur vectors. c arscnd ARPACK utility routine for timing. c dmout ARPACK utility routine that prints matrices c dvout ARPACK utility routine that prints vectors. c dlacpy LAPACK matrix copy routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dtrevc LAPACK routine to compute the eigenvectors of a matrix c in upper quasi-triangular form c dgemv Level 2 BLAS routine for matrix vector multiplication. c dcopy Level 1 BLAS that copies one vector to another . c dnrm2 Level 1 BLAS that computes the norm of a vector. c dscal Level 1 BLAS that scales a vector. c c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine dneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ierr) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, n, ldh, ldq Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), & workl(n*(n+3)) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical select(1) integer i, iconj, msglvl Double precision & temp, vl(1) c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dlacpy, dlaqrb, dtrevc, dvout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlapy2, dnrm2 external dlapy2, dnrm2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mneigh c if (msglvl .gt. 2) then call dmout (logfil, n, n, h, ldh, ndigit, & '_neigh: Entering upper Hessenberg matrix H ') end if c c %-----------------------------------------------------------% c | 1. Compute the eigenvalues, the last components of the | c | corresponding Schur vectors and the full Schur form T | c | of the current upper Hessenberg matrix H. | c | dlaqrb returns the full Schur form of H in WORKL(1:N**2) | c | and the last components of the Schur vectors in BOUNDS. | c %-----------------------------------------------------------% c call dlacpy ('All', n, n, h, ldh, workl, n) call dlaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds, & ierr) if (ierr .ne. 0) go to 9000 c if (msglvl .gt. 1) then call dvout (logfil, n, bounds, ndigit, & '_neigh: last row of the Schur matrix for H') end if c c %-----------------------------------------------------------% c | 2. Compute the eigenvectors of the full Schur form T and | c | apply the last components of the Schur vectors to get | c | the last components of the corresponding eigenvectors. | c | Remember that if the i-th and (i+1)-st eigenvalues are | c | complex conjugate pairs, then the real & imaginary part | c | of the eigenvector components are split across adjacent | c | columns of Q. | c %-----------------------------------------------------------% c call dtrevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, & n, n, workl(n*n+1), ierr) c if (ierr .ne. 0) go to 9000 c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | euclidean norms are all one. LAPACK subroutine | c | dtrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; here the magnitude of a complex | c | number (x,y) is taken to be |x| + |y|. | c %------------------------------------------------% c iconj = 0 do 10 i=1, n if ( abs( ritzi(i) ) .le. zero ) then c c %----------------------% c | Real eigenvalue case | c %----------------------% c temp = dnrm2( n, q(1,i), 1 ) call dscal ( n, one / temp, q(1,i), 1 ) else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we further normalize by the | c | square root of two. | c %-------------------------------------------% c if (iconj .eq. 0) then temp = dlapy2( dnrm2( n, q(1,i), 1 ), & dnrm2( n, q(1,i+1), 1 ) ) call dscal ( n, one / temp, q(1,i), 1 ) call dscal ( n, one / temp, q(1,i+1), 1 ) iconj = 1 else iconj = 0 end if end if 10 continue c call dgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) c if (msglvl .gt. 1) then call dvout (logfil, n, workl, ndigit, & '_neigh: Last row of the eigenvector matrix for H') end if c c %----------------------------% c | Compute the Ritz estimates | c %----------------------------% c iconj = 0 do 20 i = 1, n if ( abs( ritzi(i) ) .le. zero ) then c c %----------------------% c | Real eigenvalue case | c %----------------------% c bounds(i) = rnorm * abs( workl(i) ) else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we need to take the magnitude | c | of the last components of the two vectors | c %-------------------------------------------% c if (iconj .eq. 0) then bounds(i) = rnorm * dlapy2( workl(i), workl(i+1) ) bounds(i+1) = bounds(i) iconj = 1 else iconj = 0 end if end if 20 continue c if (msglvl .gt. 2) then call dvout (logfil, n, ritzr, ndigit, & '_neigh: Real part of the eigenvalues of H') call dvout (logfil, n, ritzi, ndigit, & '_neigh: Imaginary part of the eigenvalues of H') call dvout (logfil, n, bounds, ndigit, & '_neigh: Ritz estimates for the eigenvalues of H') end if c call arscnd (t1) tneigh = tneigh + (t1 - t0) c 9000 continue return c c %---------------% c | End of dneigh | c %---------------% c end arpack-akloeckner-07/SRC/dneupd.f0000644000175000017500000012644407162222372016566 0ustar andreasandreasc\BeginDoc c c\Name: dneupd c c\Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are derived from approximate eigenvalues and eigenvectors of c of the linear operator OP prescribed by the MODE selection in the c call to DNAUPD . DNAUPD must be called before this routine is called. c These approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c See documentation in the header of the subroutine DNAUPD for c definition of OP as well as other terms and the relation of computed c Ritz values and Ritz vectors of OP with respect to the given problem c A*z = lambda*B*z. For a brief description, see definitions of c IPARAM(7), MODE and WHICH in the documentation of DNAUPD . c c\Usage: c call dneupd c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, c LWORKL, INFO ) c c\Arguments: c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. c c DR Double precision array of dimension NEV+1. (OUTPUT) c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains c the real part of the Ritz approximations to the eigenvalues of c A*z = lambda*B*z. c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: c DR contains the real part of the Ritz values of OP computed by c DNAUPD . A further computation must be performed by the user c to transform the Ritz values computed for OP by DNAUPD to those c of the original system A*z = lambda*B*z. See remark 3 below. c c DI Double precision array of dimension NEV+1. (OUTPUT) c On exit, DI contains the imaginary part of the Ritz value c approximations to the eigenvalues of A*z = lambda*B*z associated c with DR. c c NOTE: When Ritz values are complex, they will come in complex c conjugate pairs. If eigenvectors are requested, the c corresponding Ritz vectors will also come in conjugate c pairs and the real and imaginary parts of these are c represented in two consecutive columns of the array Z c (see below). c c Z Double precision N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represent approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c The complex Ritz vector associated with the Ritz value c with positive imaginary part is stored in two consecutive c columns. The first column holds the real part of the Ritz c vector and the second column holds the imaginary part. The c Ritz vector associated with the Ritz value with negative c imaginary part is simply the complex conjugate of the Ritz vector c associated with the positive imaginary part. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by DNAUPD . In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. c c SIGMAR Double precision (INPUT) c If IPARAM(7) = 3 or 4, represents the real part of the shift. c Not referenced if IPARAM(7) = 1 or 2. c c SIGMAI Double precision (INPUT) c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. c c WORKEV Double precision work array of dimension 3*NCV. (WORKSPACE) c c **** The remaining arguments MUST be the same as for the **** c **** call to DNAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, INFO c c must be passed directly to DNEUPD following the last call c to DNAUPD . These arguments MUST NOT BE MODIFIED between c the the last call to DNAUPD and the call to DNEUPD . c c Three of these parameters (V, WORKL, INFO) are also output parameters: c c V Double precision N by NCV array. (INPUT/OUTPUT) c c Upon INPUT: the NCV columns of V contain the Arnoldi basis c vectors for OP as constructed by DNAUPD . c c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. See Remark 2 below. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the c Arnoldi basis held by V has been overwritten by the desired c Ritz vectors. If a separate array Z has been passed then c the first NCONV=IPARAM(5) columns of V will contain approximate c Schur vectors that span the desired invariant subspace. c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:ncv*ncv+3*ncv) contains information obtained in c dnaupd . They are not changed by dneupd . c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the c real and imaginary part of the untransformed Ritz values, c the upper quasi-triangular matrix for H, and the c associated matrix representation of the invariant subspace for H. c c Note: IPNTR(9:13) contains the pointer into WORKL for addresses c of the above information computed by dneupd . c ------------------------------------------------------------- c IPNTR(9): pointer to the real part of the NCV RITZ values of the c original system. c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of c the original system. c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c dneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c c = 0: Normal exit. c c = 1: The Schur form computed by LAPACK routine dlahqr c could not be reordered by LAPACK routine dtrsen . c Re-enter subroutine dneupd with IPARAM(5)=NCV and c increase the size of the arrays DR and DI to have c dimension at least dimension NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors if this error c occurs. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from calculation of a real Schur form. c Informational error from LAPACK routine dlahqr . c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine dtrevc . c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: DNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: DNEUPD got a different count of the number of converged c Ritz values than DNAUPD got. This indicates the user c probably made an error in passing data from DNAUPD to c DNEUPD or that the data was modified before entering c DNEUPD c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c ivout ARPACK utility routine that prints integers. c dmout ARPACK utility routine that prints matrices c dvout ARPACK utility routine that prints vectors. c dgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c dlacpy LAPACK matrix copy routine. c dlahqr LAPACK routine to compute the real Schur form of an c upper Hessenberg matrix. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK matrix initialization routine. c dorm2r LAPACK routine that applies an orthogonal matrix in c factored form. c dtrevc LAPACK routine to compute the eigenvectors of a matrix c in upper quasi-triangular form. c dtrsen LAPACK routine that re-orders the Schur form. c dtrmm Level 3 BLAS matrix times an upper triangular matrix. c dger Level 2 BLAS rank one update to a matrix. c dcopy Level 1 BLAS that copies one vector to another . c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dscal Level 1 BLAS that scales a vector. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c Let trans(X) denote the transpose of X. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .TRUE. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately c satisfied. Here T is the leading submatrix of order IPARAM(5) of the c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; c each 2-by-2 diagonal block has its diagonal elements equal and its c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 c diagonal block is a complex conjugate pair of Ritz values. The real c Ritz values are stored on the diagonal of T. c c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz c values computed by DNAUPD for OP to those of A*z = lambda*B*z. c Set RVEC = .true. and HOWMNY = 'A', and c compute c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. c If DI(I) is not equal to zero and DI(I+1) = - D(I), c then the desired real and imaginary parts of the Ritz value are c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), c respectively. c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper c quasi-triangular matrix of order IPARAM(5) is computed. See remark c 2 above. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine dneupd (rvec , howmny, select, dr , di, & z , ldz , sigmar, sigmai, workev, & bmat , n , which , nev , tol, & resid, ncv , v , ldv , iparam, & ipntr, workd , workl , lworkl, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Double precision & sigmar, sigmai, tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) logical select(ncv) Double precision & dr(nev+1) , di(nev+1), resid(n) , & v(ldv,ncv) , z(ldz,*) , workd(3*n), & workl(lworkl), workev(3*ncv) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0 , zero = 0.0D+0 ) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds, ierr , ih , ihbds , & iheigr, iheigi, iconj , nconv , & invsub, iuptri, iwev , iwork(1), & j , k , ldh , ldq , & mode , msglvl, outncv, ritzr , & ritzi , wri , wrr , irr , & iri , ibd , ishift, numcnv , & np , jj logical reord Double precision & conds , rnorm, sep , temp, & vl(1,1), temp1, eps23 c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy , dger , dgeqr2 , dlacpy , & dlahqr , dlaset , dmout , dorm2r , & dtrevc , dtrmm , dtrsen , dscal , & dvout , ivout c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlapy2 , dnrm2 , dlamch , ddot external dlapy2 , dnrm2 , dlamch , ddot c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, min, sqrt c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mneupd mode = iparam(7) nconv = iparam(5) info = 0 c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = dlamch ('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0 ) c c %--------------% c | Quick return | c %--------------% c ierr = 0 c if (nconv .le. 0) then ierr = -14 else if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev+1 .or. ncv .gt. n) then ierr = -3 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 6*ncv) then ierr = -7 else if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) then ierr = -13 else if (howmny .eq. 'S' ) then ierr = -12 end if c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 .and. sigmai .eq. zero) then type = 'SHIFTI' else if (mode .eq. 3 ) then type = 'REALPT' else if (mode .eq. 4 ) then type = 'IMAGPT' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %--------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | c | parts of ritz values | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | c %--------------------------------------------------------% c c %-----------------------------------------------------------% c | The following is used and set by DNEUPD . | c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | c | real part of the Ritz values. | c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | c | imaginary part of the Ritz values. | c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | c | error bounds of the Ritz values | c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | c | quasi-triangular matrix for H | c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | c | associated matrix representation of the invariant | c | subspace for H. | c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | c %-----------------------------------------------------------% c ih = ipntr(5) ritzr = ipntr(6) ritzi = ipntr(7) bounds = ipntr(8) ldh = ncv ldq = ncv iheigr = bounds + ldh iheigi = iheigr + ldh ihbds = iheigi + ldh iuptri = ihbds + ldh invsub = iuptri + ldh*ncv ipntr(9) = iheigr ipntr(10) = iheigi ipntr(11) = ihbds ipntr(12) = iuptri ipntr(13) = invsub wrr = 1 wri = ncv + 1 iwev = wri + ncv c c %-----------------------------------------% c | irr points to the REAL part of the Ritz | c | values computed by _neigh before | c | exiting _naup2. | c | iri points to the IMAGINARY part of the | c | Ritz values computed by _neigh | c | before exiting _naup2. | c | ibd points to the Ritz estimates | c | computed by _neigh before exiting | c | _naup2. | c %-----------------------------------------% c irr = ipntr(14)+ncv*ncv iri = irr+ncv ibd = iri+ncv c c %------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c %------------------------------------% c rnorm = workl(ih+2) workl(ih+2) = zero c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(irr), ndigit, & '_neupd: Real part of Ritz values passed in from _NAUPD.') call dvout (logfil, ncv, workl(iri), ndigit, & '_neupd: Imag part of Ritz values passed in from _NAUPD.') call dvout (logfil, ncv, workl(ibd), ndigit, & '_neupd: Ritz estimates passed in from _NAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(bound) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call dngets (ishift , which , nev , & np , workl(irr), workl(iri), & workl(bounds), workl , workl(np+1)) c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(irr), ndigit, & '_neupd: Real part of Ritz values after calling _NGETS.') call dvout (logfil, ncv, workl(iri), ndigit, & '_neupd: Imag part of Ritz values after calling _NGETS.') call dvout (logfil, ncv, workl(bounds), ndigit, & '_neupd: Ritz value indices after calling _NGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv temp1 = max(eps23, & dlapy2 ( workl(irr+ncv-j), workl(iri+ncv-j) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & workl(ibd+jj-1) .le. tol*temp1) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by dnaupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the dnaupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_neupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_neupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -15 go to 9000 end if c c %-----------------------------------------------------------% c | Call LAPACK routine dlahqr to compute the real Schur form | c | of the upper Hessenberg matrix returned by DNAUPD . | c | Make a copy of the upper Hessenberg matrix. | c | Initialize the Schur vector matrix Q to the identity. | c %-----------------------------------------------------------% c call dcopy (ldh*ncv, workl(ih), 1, workl(iuptri), 1) call dlaset ('All', ncv, ncv, & zero , one, workl(invsub), & ldq) call dlahqr (.true., .true. , ncv, & 1 , ncv , workl(iuptri), & ldh , workl(iheigr), workl(iheigi), & 1 , ncv , workl(invsub), & ldq , ierr) call dcopy (ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call dvout (logfil, ncv, workl(iheigr), ndigit, & '_neupd: Real part of the eigenvalues of H') call dvout (logfil, ncv, workl(iheigi), ndigit, & '_neupd: Imaginary part of the Eigenvalues of H') call dvout (logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the Schur vector matrix') if (msglvl .gt. 3) then call dmout (logfil , ncv, ncv , & workl(iuptri), ldh, ndigit, & '_neupd: The upper quasi-triangular matrix ') end if end if c if (reord) then c c %-----------------------------------------------------% c | Reorder the computed upper quasi-triangular matrix. | c %-----------------------------------------------------% c call dtrsen ('None' , 'V' , & select , ncv , & workl(iuptri), ldh , & workl(invsub), ldq , & workl(iheigr), workl(iheigi), & nconv , conds , & sep , workl(ihbds) , & ncv , iwork , & 1 , ierr) c if (ierr .eq. 1) then info = 1 go to 9000 end if c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(iheigr), ndigit, & '_neupd: Real part of the eigenvalues of H--reordered') call dvout (logfil, ncv, workl(iheigi), ndigit, & '_neupd: Imag part of the eigenvalues of H--reordered') if (msglvl .gt. 3) then call dmout (logfil , ncv, ncv , & workl(iuptri), ldq, ndigit, & '_neupd: Quasi-triangular matrix after re-ordering') end if end if c end if c c %---------------------------------------% c | Copy the last row of the Schur vector | c | into workl(ihbds). This will be used | c | to compute the Ritz estimates of | c | converged Ritz values. | c %---------------------------------------% c call dcopy (ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) c c %----------------------------------------------------% c | Place the computed eigenvalues of H into DR and DI | c | if a spectral transformation was not used. | c %----------------------------------------------------% c if (type .eq. 'REGULR') then call dcopy (nconv, workl(iheigr), 1, dr, 1) call dcopy (nconv, workl(iheigi), 1, di, 1) end if c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(invsub,ldq). | c %----------------------------------------------------------% c call dgeqr2 (ncv, nconv , workl(invsub), & ldq, workev, workev(ncv+1), & ierr) c c %---------------------------------------------------------% c | * Postmultiply V by Q using dorm2r . | c | * Copy the first NCONV columns of VQ into Z. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(iheigr) and workl(iheigi) | c | The first NCONV columns of V are now approximate Schur | c | vectors associated with the real upper quasi-triangular | c | matrix of order NCONV in workl(iuptri) | c %---------------------------------------------------------% c call dorm2r ('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , v , & ldv , workd(n+1) , ierr) call dlacpy ('All', n, nconv, v, ldv, z, ldz) c do 20 j=1, nconv c c %---------------------------------------------------% c | Perform both a column and row scaling if the | c | diagonal element of workl(invsub,ldq) is negative | c | I'm lazy and don't take advantage of the upper | c | quasi-triangular form of workl(iuptri,ldq) | c | Note that since Q is orthogonal, R is a diagonal | c | matrix consisting of plus or minus ones | c %---------------------------------------------------% c if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then call dscal (nconv, -one, workl(iuptri+j-1), ldq) call dscal (nconv, -one, workl(iuptri+(j-1)*ldq), 1) end if c 20 continue c if (howmny .eq. 'A') then c c %--------------------------------------------% c | Compute the NCONV wanted eigenvectors of T | c | located in workl(iuptri,ldq). | c %--------------------------------------------% c do 30 j=1, ncv if (j .le. nconv) then select(j) = .true. else select(j) = .false. end if 30 continue c call dtrevc ('Right', 'Select' , select , & ncv , workl(iuptri), ldq , & vl , 1 , workl(invsub), & ldq , ncv , outncv , & workev , ierr) c if (ierr .ne. 0) then info = -9 go to 9000 end if c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | dtrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; | c %------------------------------------------------% c iconj = 0 do 40 j=1, nconv c if ( workl(iheigi+j-1) .eq. zero ) then c c %----------------------% c | real eigenvalue case | c %----------------------% c temp = dnrm2 ( ncv, workl(invsub+(j-1)*ldq), 1 ) call dscal ( ncv, one / temp, & workl(invsub+(j-1)*ldq), 1 ) c else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we further normalize by the | c | square root of two. | c %-------------------------------------------% c if (iconj .eq. 0) then temp = dlapy2 (dnrm2 (ncv, & workl(invsub+(j-1)*ldq), & 1), & dnrm2 (ncv, & workl(invsub+j*ldq), & 1)) call dscal (ncv, one/temp, & workl(invsub+(j-1)*ldq), 1 ) call dscal (ncv, one/temp, & workl(invsub+j*ldq), 1 ) iconj = 1 else iconj = 0 end if c end if c 40 continue c call dgemv ('T', ncv, nconv, one, workl(invsub), & ldq, workl(ihbds), 1, zero, workev, 1) c iconj = 0 do 45 j=1, nconv if (workl(iheigi+j-1) .ne. zero) then c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c %-------------------------------------------% c if (iconj .eq. 0) then workev(j) = dlapy2 (workev(j), workev(j+1)) workev(j+1) = workev(j) iconj = 1 else iconj = 0 end if end if 45 continue c if (msglvl .gt. 2) then call dcopy (ncv, workl(invsub+ncv-1), ldq, & workl(ihbds), 1) call dvout (logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the eigenvector matrix for T') if (msglvl .gt. 3) then call dmout (logfil, ncv, ncv, workl(invsub), ldq, & ndigit, '_neupd: The eigenvector matrix for T') end if end if c c %---------------------------------------% c | Copy Ritz estimates into workl(ihbds) | c %---------------------------------------% c call dcopy (nconv, workev, 1, workl(ihbds), 1) c c %---------------------------------------------------------% c | Compute the QR factorization of the eigenvector matrix | c | associated with leading portion of T in the first NCONV | c | columns of workl(invsub,ldq). | c %---------------------------------------------------------% c call dgeqr2 (ncv, nconv , workl(invsub), & ldq, workev, workev(ncv+1), & ierr) c c %----------------------------------------------% c | * Postmultiply Z by Q. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now contains the | c | Ritz vectors associated with the Ritz values | c | in workl(iheigr) and workl(iheigi). | c %----------------------------------------------% c call dorm2r ('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , z , & ldz , workd(n+1) , ierr) c call dtrmm ('Right' , 'Upper' , 'No transpose', & 'Non-unit', n , nconv , & one , workl(invsub), ldq , & z , ldz) c end if c else c c %------------------------------------------------------% c | An approximate invariant subspace is not needed. | c | Place the Ritz values computed DNAUPD into DR and DI | c %------------------------------------------------------% c call dcopy (nconv, workl(ritzr), 1, dr, 1) call dcopy (nconv, workl(ritzi), 1, di, 1) call dcopy (nconv, workl(ritzr), 1, workl(iheigr), 1) call dcopy (nconv, workl(ritzi), 1, workl(iheigi), 1) call dcopy (nconv, workl(bounds), 1, workl(ihbds), 1) end if c c %------------------------------------------------% c | Transform the Ritz values and possibly vectors | c | and corresponding error bounds of OP to those | c | of A*x = lambda*B*x. | c %------------------------------------------------% c if (type .eq. 'REGULR') then c if (rvec) & call dscal (ncv, rnorm, workl(ihbds), 1) c else c c %---------------------------------------% c | A spectral transformation was used. | c | * Determine the Ritz estimates of the | c | Ritz values in the original system. | c %---------------------------------------% c if (type .eq. 'SHIFTI') then c if (rvec) & call dscal (ncv, rnorm, workl(ihbds), 1) c do 50 k=1, ncv temp = dlapy2 ( workl(iheigr+k-1), & workl(iheigi+k-1) ) workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) & / temp / temp 50 continue c else if (type .eq. 'REALPT') then c do 60 k=1, ncv 60 continue c else if (type .eq. 'IMAGPT') then c do 70 k=1, ncv 70 continue c end if c c %-----------------------------------------------------------% c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | c | Rayleigh quotients or a projection. See remark 3 above.| c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c %-----------------------------------------------------------% c if (type .eq. 'SHIFTI') then c do 80 k=1, ncv temp = dlapy2 ( workl(iheigr+k-1), & workl(iheigi+k-1) ) workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp & + sigmar workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp & + sigmai 80 continue c call dcopy (nconv, workl(iheigr), 1, dr, 1) call dcopy (nconv, workl(iheigi), 1, di, 1) c else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then c call dcopy (nconv, workl(iheigr), 1, dr, 1) call dcopy (nconv, workl(iheigi), 1, di, 1) c end if c end if c if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then call dvout (logfil, nconv, dr, ndigit, & '_neupd: Untransformed real part of the Ritz valuess.') call dvout (logfil, nconv, di, ndigit, & '_neupd: Untransformed imag part of the Ritz valuess.') call dvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Ritz estimates of untransformed Ritz values.') else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then call dvout (logfil, nconv, dr, ndigit, & '_neupd: Real parts of converged Ritz values.') call dvout (logfil, nconv, di, ndigit, & '_neupd: Imag parts of converged Ritz values.') call dvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Associated Ritz estimates.') end if c c %-------------------------------------------------% c | Eigenvector Purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 2. | c %-------------------------------------------------% c if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then c c %------------------------------------------------% c | Purify the computed Ritz vectors by adding a | c | little bit of the residual vector: | c | T | c | resid(:)*( e s ) / theta | c | NCV | c | where H s = s theta. Remember that when theta | c | has nonzero imaginary part, the corresponding | c | Ritz vector is stored across two columns of Z. | c %------------------------------------------------% c iconj = 0 do 110 j=1, nconv if (workl(iheigi+j-1) .eq. zero) then workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / & workl(iheigr+j-1) else if (iconj .eq. 0) then temp = dlapy2 ( workl(iheigr+j-1), workl(iheigi+j-1) ) workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * & workl(iheigr+j-1) + & workl(invsub+j*ldq+ncv-1) * & workl(iheigi+j-1) ) / temp / temp workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * & workl(iheigr+j-1) - & workl(invsub+(j-1)*ldq+ncv-1) * & workl(iheigi+j-1) ) / temp / temp iconj = 1 else iconj = 0 end if 110 continue c c %---------------------------------------% c | Perform a rank one update to Z and | c | purify all the Ritz vectors together. | c %---------------------------------------% c call dger (n, nconv, one, resid, 1, workev, 1, z, ldz) c end if c 9000 continue c return c c %---------------% c | End of DNEUPD | c %---------------% c end arpack-akloeckner-07/SRC/dngets.f0000644000175000017500000001753410670622032016565 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dngets c c\Description: c Given the eigenvalues of the upper Hessenberg matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: call this even in the case of user specified shifts in order c to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call dngets c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> want the KEV eigenvalues of largest magnitude. c 'SM' -> want the KEV eigenvalues of smallest magnitude. c 'LR' -> want the KEV eigenvalues of largest real part. c 'SR' -> want the KEV eigenvalues of smallest real part. c 'LI' -> want the KEV eigenvalues of largest imaginary part. c 'SI' -> want the KEV eigenvalues of smallest imaginary part. c c KEV Integer. (INPUT/OUTPUT) c INPUT: KEV+NP is the size of the matrix H. c OUTPUT: Possibly increases KEV by one to keep complex conjugate c pairs together. c c NP Integer. (INPUT/OUTPUT) c Number of implicit shifts to be computed. c OUTPUT: Possibly decreases NP by one to keep complex conjugate c pairs together. c c RITZR, Double precision array of length KEV+NP. (INPUT/OUTPUT) c RITZI On INPUT, RITZR and RITZI contain the real and imaginary c parts of the eigenvalues of H. c On OUTPUT, RITZR and RITZI are sorted so that the unwanted c eigenvalues are in the first NP locations and the wanted c portion is in the last KEV locations. When exact shifts are c selected, the unwanted part corresponds to the shifts to c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues c are further sorted so that the ones with largest Ritz values c are first. c c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** c c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dsortc ARPACK sorting routine. c dcopy Level 1 BLAS that copies one vector to another . c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. xxxx c c\EndLib c c----------------------------------------------------------------------- c subroutine dngets ( ishift, which, kev, np, ritzr, ritzi, bounds, & shiftr, shifti ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), & shiftr(1), shifti(1) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0, zero = 0.0) c c %---------------% c | Local Scalars | c %---------------% c integer msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dsortc, arscnd c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mngets c c %----------------------------------------------------% c | LM, SM, LR, SR, LI, SI case. | c | Sort the eigenvalues of H into the desired order | c | and apply the resulting order to BOUNDS. | c | The eigenvalues are sorted so that the wanted part | c | are always in the last KEV locations. | c | We first do a pre-processing sort in order to keep | c | complex conjugate pairs together | c %----------------------------------------------------% c if (which .eq. 'LM') then call dsortc ('LR', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SM') then call dsortc ('SR', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'LR') then call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SR') then call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'LI') then call dsortc ('LM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SI') then call dsortc ('SM', .true., kev+np, ritzr, ritzi, bounds) end if c call dsortc (which, .true., kev+np, ritzr, ritzi, bounds) c c %-------------------------------------------------------% c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | c | Accordingly decrease NP by one. In other words keep | c | complex conjugate pairs together. | c %-------------------------------------------------------% c if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then np = np - 1 kev = kev + 1 end if c if ( ishift .eq. 1 ) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first | c | This will tend to minimize the effects of the | c | forward instability of the iteration when they shifts | c | are applied in subroutine dnapps. | c | Be careful and use 'SR' since we want to sort BOUNDS! | c %-------------------------------------------------------% c call dsortc ( 'SR', .true., np, bounds, ritzr, ritzi ) end if c call arscnd (t1) tngets = tngets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') call ivout (logfil, 1, np, ndigit, '_ngets: NP is') call dvout (logfil, kev+np, ritzr, ndigit, & '_ngets: Eigenvalues of current H matrix -- real part') call dvout (logfil, kev+np, ritzi, ndigit, & '_ngets: Eigenvalues of current H matrix -- imag part') call dvout (logfil, kev+np, bounds, ndigit, & '_ngets: Ritz estimates of the current KEV+NP Ritz values') end if c return c c %---------------% c | End of dngets | c %---------------% c end arpack-akloeckner-07/SRC/dsaitr.f0000644000175000017500000007413310670622032016565 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step symmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in dsaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call dsaitr c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and does not need to be c recomputed in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of matrix B that defines the c semi-inner product for the operator OP. See dsaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current order of H and the number of columns of V. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c MODE Integer. (INPUT) c Signifies which form for "OP". If MODE=2 then c a reduction in the number of B matrix vector multiplies c is possible since the B-norm of OP*x is equivalent to c the inv(B)-norm of A*x. c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Double precision scalar. (INPUT/OUTPUT) c On INPUT the B-norm of r_{k}. c On OUTPUT the B-norm of the updated residual r_{k+p}. c c V Double precision N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (K+NP) by 2 array. (INPUT/OUTPUT) c H is used to store the generated symmetric tridiagonal matrix c with the subdiagonal in the first column starting at H(2,1) c and the main diagonal in the second column. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On INPUT, WORKD(1:N) = B*RESID where RESID is associated c with the K step Arnoldi factorization. Used to save some c computation at the first step. c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated c with the K+NP step Arnoldi factorization. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of an invariant subspace of OP is found that is c less than K + NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c dmout ARPACK utility routine that prints matrices. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dlascl LAPACK routine for careful scaling of a matrix. c dgemv Level 2 BLAS routine for matrix vector multiplication. c daxpy Level 1 BLAS that computes a vector triad. c dscal Level 1 BLAS that scales a vector. c dcopy Level 1 BLAS that copies one vector to another . c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in dsaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c alphaj <- j-th component of w_{j} c rnorm = || r_{j} || c betaj+1 = rnorm c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine dsaitr & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, mode, np Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Double precision & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, & infol, jj Double precision & rnorm1, wnorm, safmin, temp1 save orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, & rnorm1, safmin, wnorm c c %-----------------------% c | Local Array Arguments | c %-----------------------% c Double precision & xtemp(2) c c %----------------------% c | External Subroutines | c %----------------------% c external daxpy, dcopy, dscal, dgemv, dgetv0, dvout, dmout, & dlascl, ivout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2, dlamch external ddot, dnrm2, dlamch c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then first = .false. c c %--------------------------------% c | safmin = safe minimum is such | c | that 1/sfmin does not overflow | c %--------------------------------% c safmin = dlamch('safmin') end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = msaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. c c %--------------------------------% c | Pointer to the current step of | c | the factorization to build | c %--------------------------------% c j = k + 1 c c %------------------------------------------% c | Pointers used for reverse communication | c | when using WORKD. | c %------------------------------------------% c ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | dgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %------------------------------% c | Else this is the first step. | c %------------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% c 1000 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, j, ndigit, & '_saitr: generating Arnoldi vector no.') call dvout (logfil, 1, rnorm, ndigit, & '_saitr: B-norm of the current residual =') end if c c %---------------------------------------------------------% c | Check for exact zero. Equivalent to determing whether a | c | j-step Arnoldi factorization is present. | c %---------------------------------------------------------% c if (rnorm .gt. zero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_saitr: ****** restart at step ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call dgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call arscnd (t1) tsaitr = tsaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call dcopy (n, resid, 1, v(1,j), 1) if (rnorm .ge. safmin) then temp1 = one / rnorm call dscal (n, temp1, v(1,j), 1) call dscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine SLASCL | c %-----------------------------------------% c call dlascl ('General', i, i, rnorm, one, n, 1, & v(1,j), n, infol) call dlascl ('General', i, i, rnorm, one, n, 1, & workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call arscnd (t2) call dcopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %-----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | c %-----------------------------------% c call arscnd (t3) tmvopx = tmvopx + (t3 - t2) c step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call dcopy (n, workd(irj), 1, resid, 1) c c %-------------------------------------------% c | STEP 4: Finish extending the symmetric | c | Arnoldi to length j. If MODE = 2 | c | then B*OP = B*inv(B)*A = A and | c | we don't need to compute B*OP. | c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | c | assumed to have A*v_{j}. | c %-------------------------------------------% c if (mode .eq. 2) go to 65 call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy(n, resid, 1 , workd(ipj), 1) end if 60 continue c c %-----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | c %-----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c 65 continue if (mode .eq. 2) then c c %----------------------------------% c | Note that the B-norm of OP*v_{j} | c | is the inv(B)-norm of A*v_{j}. | c %----------------------------------% c wnorm = ddot (n, resid, 1, workd(ivj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'G') then wnorm = ddot (n, resid, 1, workd(ipj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'I') then wnorm = dnrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c if (mode .ne. 2 ) then call dgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, & workd(irj), 1) else if (mode .eq. 2) then call dgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, & workd(irj), 1) end if c c %--------------------------------------% c | Orthgonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call dgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, & resid, 1) c c %--------------------------------------% c | Extend H to have j rows and columns. | c %--------------------------------------% c h(j,2) = workd(irj + j - 1) if (j .eq. 1 .or. rstart) then h(j,1) = zero else h(j,1) = rnorm end if call arscnd (t4) c orth1 = .true. iter = 0 c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd(ipj), 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c %-----------------------------------------------------------% c if (rnorm .gt. 0.717*wnorm) go to 100 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then xtemp(1) = wnorm xtemp(2) = rnorm call dvout (logfil, 2, xtemp, ndigit, & '_saitr: re-orthonalization ; wnorm and rnorm are') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call dgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %----------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) + | c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | c | H(j,j) is updated. | c %----------------------------------------------% c call dgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) c if (j .eq. 1 .or. rstart) h(j,1) = zero h(j,2) = h(j,2) + workd(irj + j - 1) c orth2 = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then rnorm1 = ddot (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt(abs(rnorm1)) else if (bmat .eq. 'I') then rnorm1 = dnrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_saitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then xtemp(1) = rnorm xtemp(2) = rnorm1 call dvout (logfil, 2, xtemp, ndigit, & '_saitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if (rnorm1 .gt. 0.717*rnorm) then c c %--------------------------------% c | No need for further refinement | c %--------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = zero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call arscnd (t5) titref = titref + (t5 - t4) c c %----------------------------------------------------------% c | Make sure the last off-diagonal element is non negative | c | If not perform a similarity transformation on H(1:j,1:j) | c | and scale v(:,j) by -1. | c %----------------------------------------------------------% c if (h(j,1) .lt. zero) then h(j,1) = -h(j,1) if ( j .lt. k+np) then call dscal(n, -one, v(1,j+1), 1) else call dscal(n, -one, resid, 1) end if end if c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call arscnd (t1) tsaitr = tsaitr + (t1 - t0) ido = 99 c if (msglvl .gt. 1) then call dvout (logfil, k+np, h(1,2), ndigit, & '_saitr: main diagonal of matrix H of step K+NP.') if (k+np .gt. 1) then call dvout (logfil, k+np-1, h(2,1), ndigit, & '_saitr: sub diagonal of matrix H of step K+NP.') end if end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of dsaitr | c %---------------% c end arpack-akloeckner-07/SRC/dsapps.f0000644000175000017500000004412210670622032016564 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP shifts implicitly resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix of order KEV+NP. Q is the product of c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi c factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call dsapps c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. dimension of matrix A. c c KEV Integer. (INPUT) c INPUT: KEV+NP is the size of the input matrix H. c OUTPUT: KEV is the size of the updated matrix HNEW. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFT Double precision array of length NP. (INPUT) c The shifts to be applied. c c V Double precision N by (KEV+NP) array. (INPUT/OUTPUT) c INPUT: V contains the current KEV+NP Arnoldi vectors. c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors c are in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (KEV+NP) by 2 array. (INPUT/OUTPUT) c INPUT: H contains the symmetric tridiagonal matrix of the c Arnoldi factorization with the subdiagonal in the 1st column c starting at H(2,1) and the main diagonal in the 2nd column. c OUTPUT: H contains the updated tridiagonal matrix in the c KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Double precision array of length (N). (INPUT/OUTPUT) c INPUT: RESID contains the the residual vector r_{k+p}. c OUTPUT: RESID is the updated residual vector rnew_{k}. c c Q Double precision KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations during the bulge c chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKD Double precision work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dlartg LAPACK Givens rotation construction routine. c dlacpy LAPACK matrix copy routine. c dlaset LAPACK matrix initialization routine. c dgemv Level 2 BLAS routine for matrix vector multiplication. c daxpy Level 1 BLAS that computes a vector triad. c dcopy Level 1 BLAS that copies one vector to another. c dscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the subblocks of c the tridiagonal matrix H and not just to the submatrix that it c comes from. This routine assumes that the subdiagonal elements c of H that are stored in h(1:kev+np,1) are nonegative upon input c and enforce this condition upon output. This version incorporates c deflation. See code for documentation. c c\EndLib c c----------------------------------------------------------------------- c subroutine dsapps & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), & v(ldv,kev+np), workd(2*n) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c integer i, iend, istart, itop, j, jj, kplusp, msglvl logical first Double precision & a1, a2, a3, a4, big, c, epsmch, f, g, r, s save epsmch, first c c c %----------------------% c | External Subroutines | c %----------------------% c external daxpy, dcopy, dscal, dlacpy, dlartg, dlaset, dvout, & ivout, arscnd, dgemv c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch external dlamch c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then epsmch = dlamch('Epsilon-Machine') first = .false. end if itop = 1 c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = msapps c kplusp = kev + np c c %----------------------------------------------% c | Initialize Q to the identity matrix of order | c | kplusp used to accumulate the rotations. | c %----------------------------------------------% c call dlaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------------------% c | Apply the np shifts implicitly. Apply each shift to the | c | whole matrix and not just to the submatrix from which it | c | comes. | c %----------------------------------------------------------% c do 90 jj = 1, np c istart = itop c c %----------------------------------------------------------% c | Check for splitting and deflation. Currently we consider | c | an off-diagonal element h(i+1,1) negligible if | c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | c | for i=1:KEV+NP-1. | c | If above condition tests true then we set h(i+1,1) = 0. | c | Note that h(1:KEV+NP,1) are assumed to be non negative. | c %----------------------------------------------------------% c 20 continue c c %------------------------------------------------% c | The following loop exits early if we encounter | c | a negligible off diagonal element. | c %------------------------------------------------% c do 30 i = istart, kplusp-1 big = abs(h(i,2)) + abs(h(i+1,2)) if (h(i+1,1) .le. epsmch*big) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_sapps: deflation at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_sapps: occured before shift number.') call dvout (logfil, 1, h(i+1,1), ndigit, & '_sapps: the corresponding off diagonal element') end if h(i+1,1) = zero iend = i go to 40 end if 30 continue iend = kplusp 40 continue c if (istart .lt. iend) then c c %--------------------------------------------------------% c | Construct the plane rotation G'(istart,istart+1,theta) | c | that attempts to drive h(istart+1,1) to zero. | c %--------------------------------------------------------% c f = h(istart,2) - shift(jj) g = h(istart+1,1) call dlartg (f, g, c, s, r) c c %-------------------------------------------------------% c | Apply rotation to the left and right of H; | c | H <- G' * H * G, where G = G(istart,istart+1,theta). | c | This will create a "bulge". | c %-------------------------------------------------------% c a1 = c*h(istart,2) + s*h(istart+1,1) a2 = c*h(istart+1,1) + s*h(istart+1,2) a4 = c*h(istart+1,2) - s*h(istart+1,1) a3 = c*h(istart+1,1) - s*h(istart,2) h(istart,2) = c*a1 + s*a2 h(istart+1,2) = c*a4 - s*a3 h(istart+1,1) = c*a3 + s*a4 c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 60 j = 1, min(istart+jj,kplusp) a1 = c*q(j,istart) + s*q(j,istart+1) q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) q(j,istart) = a1 60 continue c c c %----------------------------------------------% c | The following loop chases the bulge created. | c | Note that the previous rotation may also be | c | done within the following loop. But it is | c | kept separate to make the distinction among | c | the bulge chasing sweeps and the first plane | c | rotation designed to drive h(istart+1,1) to | c | zero. | c %----------------------------------------------% c do 70 i = istart+1, iend-1 c c %----------------------------------------------% c | Construct the plane rotation G'(i,i+1,theta) | c | that zeros the i-th bulge that was created | c | by G(i-1,i,theta). g represents the bulge. | c %----------------------------------------------% c f = h(i,1) g = s*h(i+1,1) c c %----------------------------------% c | Final update with G(i-1,i,theta) | c %----------------------------------% c h(i+1,1) = c*h(i+1,1) call dlartg (f, g, c, s, r) c c %-------------------------------------------% c | The following ensures that h(1:iend-1,1), | c | the first iend-2 off diagonal of elements | c | H, remain non negative. | c %-------------------------------------------% c if (r .lt. zero) then r = -r c = -c s = -s end if c c %--------------------------------------------% c | Apply rotation to the left and right of H; | c | H <- G * H * G', where G = G(i,i+1,theta) | c %--------------------------------------------% c h(i,1) = r c a1 = c*h(i,2) + s*h(i+1,1) a2 = c*h(i+1,1) + s*h(i+1,2) a3 = c*h(i+1,1) - s*h(i,2) a4 = c*h(i+1,2) - s*h(i+1,1) c h(i,2) = c*a1 + s*a2 h(i+1,2) = c*a4 - s*a3 h(i+1,1) = c*a3 + s*a4 c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 50 j = 1, min( i+jj, kplusp ) a1 = c*q(j,i) + s*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = a1 50 continue c 70 continue c end if c c %--------------------------% c | Update the block pointer | c %--------------------------% c istart = iend + 1 c c %------------------------------------------% c | Make sure that h(iend,1) is non-negative | c | If not then set h(iend,1) <-- -h(iend,1) | c | and negate the last column of Q. | c | We have effectively carried out a | c | similarity on transformation H | c %------------------------------------------% c if (h(iend,1) .lt. zero) then h(iend,1) = -h(iend,1) call dscal(kplusp, -one, q(1,iend), 1) end if c c %--------------------------------------------------------% c | Apply the same shift to the next block if there is any | c %--------------------------------------------------------% c if (iend .lt. kplusp) go to 20 c c %-----------------------------------------------------% c | Check if we can increase the the start of the block | c %-----------------------------------------------------% c do 80 i = itop, kplusp-1 if (h(i+1,1) .gt. zero) go to 90 itop = itop + 1 80 continue c c %-----------------------------------% c | Finished applying the jj-th shift | c %-----------------------------------% c 90 continue c c %------------------------------------------% c | All shifts have been applied. Check for | c | more possible deflation that might occur | c | after the last shift is applied. | c %------------------------------------------% c do 100 i = itop, kplusp-1 big = abs(h(i,2)) + abs(h(i+1,2)) if (h(i+1,1) .le. epsmch*big) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_sapps: deflation at row/column no.') call dvout (logfil, 1, h(i+1,1), ndigit, & '_sapps: the corresponding off diagonal element') end if h(i+1,1) = zero end if 100 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is not necessary if h(kev+1,1) = 0. | c %-------------------------------------------------% c if ( h(kev+1,1) .gt. zero ) & call dgemv ('N', n, kplusp, one, v, ldv, & q(1,kev+1), 1, zero, workd(n+1), 1) c c %-------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage that Q is an upper triangular matrix | c | with lower bandwidth np. | c | Place results in v(:,kplusp-kev:kplusp) temporarily. | c %-------------------------------------------------------% c do 130 i = 1, kev call dgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call dcopy (n, workd, 1, v(1,kplusp-i+1), 1) 130 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call dlacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) c c %--------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the | c | appropriate place if h(kev+1,1) .ne. zero. | c %--------------------------------------------% c if ( h(kev+1,1) .gt. zero ) & call dcopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kev+p}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call dscal (n, q(kplusp,kev), resid, 1) if (h(kev+1,1) .gt. zero) & call daxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call dvout (logfil, 1, q(kplusp,kev), ndigit, & '_sapps: sigmak of the updated residual vector') call dvout (logfil, 1, h(kev+1,1), ndigit, & '_sapps: betak of the updated residual vector') call dvout (logfil, kev, h(1,2), ndigit, & '_sapps: updated main diagonal of H for next iteration') if (kev .gt. 1) then call dvout (logfil, kev-1, h(2,1), ndigit, & '_sapps: updated sub diagonal of H for next iteration') end if end if c call arscnd (t1) tsapps = tsapps + (t1 - t0) c 9000 continue return c c %---------------% c | End of dsapps | c %---------------% c end arpack-akloeckner-07/SRC/dsaup2.f0000644000175000017500000007712710670622032016503 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsaup2 c c\Description: c Intermediate level interface called by dsaupd. c c\Usage: c call dsaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, c IPNTR, WORKD, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in dsaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in dsaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi/Lanczos iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV since a leading block of the current c upper Tridiagonal matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Double precision N by (NEV+NP) array. (INPUT/OUTPUT) c The Lanczos basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Double precision (NEV+NP) by 2 array. (OUTPUT) c H is used to store the generated symmetric tridiagonal matrix c The subdiagonal is stored in the first column of H starting c at H(2,1). The main diagonal is stored in the second column c of H starting at H(1,2). If dsaup2 converges store the c B-norm of the final residual vector in H(1,1). c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Double precision array of length NEV+NP. (OUTPUT) c RITZ(1:NEV) contains the computed Ritz values of OP. c c BOUNDS Double precision array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. c c Q Double precision (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Double precision array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in the computation of the c tridiagonal eigenvalue problem, the calculation and c application of the shifts and convergence checking. c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations c of WORKL are used in reverse communication to hold the user c supplied shifts. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Lanczos iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in one of c the spectral transformation modes. X is the current c operand. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Lanczos iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in dsaupd. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: All possible eigenvalues of OP has been found. c NP returns the size of the invariant subspace c spanning the operator OP. c = 2: No shifts could be applied. c = -8: Error return from trid. eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Lanczos factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c c\Routines called: c dgetv0 ARPACK initial vector generation routine. c dsaitr ARPACK Lanczos factorization routine. c dsapps ARPACK application of implicit shifts routine. c dsconv ARPACK convergence of Ritz values routine. c dseigt ARPACK compute Ritz values and error bounds routine. c dsgets ARPACK reorder Ritz values and error bounds routine. c dsortr ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dcopy Level 1 BLAS that copies one vector to another. c ddot Level 1 BLAS that computes the scalar product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dscal Level 1 BLAS that scales a vector. c dswap Level 1 BLAS that swaps two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.4' c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) c c\SCCS Information: @(#) c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dsaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, & q, ldq, workl, ipntr, workd, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, & n, mode, nev, np Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Double precision & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), & ritz(nev+np), v(ldv,nev+np), workd(3*n), & workl(3*(nev+np)) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c character wprime*2 logical cnorm, getv0, initv, update, ushift integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, & np0, nptemp, nevd2, nevm2, kp(3) Double precision & rnorm, temp, eps23 save cnorm, getv0, initv, update, ushift, & iter, kplusp, msglvl, nconv, nev0, np0, & rnorm, eps23 c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dgetv0, dsaitr, dscal, dsconv, dseigt, dsgets, & dsapps, dsortr, dvout, ivout, arscnd, dswap c c %--------------------% c | External Functions | c %--------------------% c Double precision & ddot, dnrm2, dlamch external ddot, dnrm2, dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = msaup2 c c %---------------------------------% c | Set machine dependent constant. | c %---------------------------------% c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0/3.0D+0) c c %-------------------------------------% c | nev0 and np0 are integer variables | c | hold the initial values of NEV & NP | c %-------------------------------------% c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvlues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev0 + np0 nconv = 0 iter = 0 c c %--------------------------------------------% c | Set flags for computing the first NEV steps | c | of the Lanczos factorization. | c %--------------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call dgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. zero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1200 end if getv0 = .false. ido = 0 end if c c %------------------------------------------------------------% c | Back from reverse communication: continue with update step | c %------------------------------------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Lanczos factorization | c %----------------------------------------------------------% c call dsaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then c c %-----------------------------------------------------% c | dsaitr was unable to build an Lanczos factorization | c | of length NEV0. INFO is returned with the size of | c | the factorization built. Exit main loop. | c %-----------------------------------------------------% c np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N LANCZOS I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Lanczos | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_saup2: **** Start of major iteration number ****') end if if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_saup2: The length of the current Lanczos factorization') call ivout (logfil, 1, np, ndigit, & '_saup2: Extend the Lanczos factorization by') end if c c %------------------------------------------------------------% c | Compute NP additional steps of the Lanczos factorization. | c %------------------------------------------------------------% c ido = 0 20 continue update = .true. c call dsaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, & ldv, h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then c c %-----------------------------------------------------% c | dsaitr was unable to build an Lanczos factorization | c | of length NEV0+NP0. INFO is returned with the size | c | of the factorization built. Exit main loop. | c %-----------------------------------------------------% c np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call dvout (logfil, 1, rnorm, ndigit, & '_saup2: Current B-norm of residual for factorization') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current symmetric tridiagonal matrix. | c %--------------------------------------------------------% c call dseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %----------------------------------------------------% c | Make a copy of eigenvalues and corresponding error | c | bounds obtained from _seigt. | c %----------------------------------------------------% c call dcopy(kplusp, ritz, 1, workl(kplusp+1), 1) call dcopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The selection is based on the requested number of | c | eigenvalues instead of the current NEV and NP to | c | prevent possible misconvergence. | c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | c %---------------------------------------------------% c nev = nev0 np = np0 call dsgets (ishift, which, nev, np, ritz, bounds, workl) c c %-------------------% c | Convergence test. | c %-------------------% c call dcopy (nev, bounds(np+1), 1, workl(np+1), 1) call dsconv (nev, ritz(np+1), workl(np+1), tol, nconv) c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = nconv call ivout (logfil, 3, kp, ndigit, & '_saup2: NEV, NP, NCONV are') call dvout (logfil, kplusp, ritz, ndigit, & '_saup2: The eigenvalues of H') call dvout (logfil, kplusp, bounds, ndigit, & '_saup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. nev0) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP since we don't want to | c | swap overlapping locations. | c %------------------------------------------------% c if (which .eq. 'BE') then c c %-----------------------------------------------------% c | Both ends of the spectrum are requested. | c | Sort the eigenvalues into algebraically decreasing | c | order first then swap low end of the spectrum next | c | to high end in appropriate locations. | c | NOTE: when np < floor(nev/2) be careful not to swap | c | overlapping locations. | c %-----------------------------------------------------% c wprime = 'SA' call dsortr (wprime, .true., kplusp, ritz, bounds) nevd2 = nev0 / 2 nevm2 = nev0 - nevd2 if ( nev .gt. 1 ) then call dswap ( min(nevd2,np), ritz(nevm2+1), 1, & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) call dswap ( min(nevd2,np), bounds(nevm2+1), 1, & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) end if c else c c %--------------------------------------------------% c | LM, SM, LA, SA case. | c | Sort the eigenvalues of H into the an order that | c | is opposite to WHICH, and apply the resulting | c | order to BOUNDS. The eigenvalues are sorted so | c | that the wanted part are always within the first | c | NEV locations. | c %--------------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LA') wprime = 'SA' if (which .eq. 'SA') wprime = 'LA' c call dsortr (wprime, .true., kplusp, ritz, bounds) c end if c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23,magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, nev0 temp = max( eps23, abs(ritz(j)) ) bounds(j) = bounds(j)/temp 35 continue c c %----------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | esitmates. This will push all the converged ones | c | towards the front of ritzr, ritzi, bounds | c | (in the case when NCONV < NEV.) | c %----------------------------------------------------% c wprime = 'LA' call dsortr(wprime, .true., nev0, bounds, ritz) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, nev0 temp = max( eps23, abs(ritz(j)) ) bounds(j) = bounds(j)*temp 40 continue c c %--------------------------------------------------% c | Sort the "converged" Ritz values again so that | c | the "threshold" values and their associated Ritz | c | estimates appear at the appropriate position in | c | ritz and bound. | c %--------------------------------------------------% c if (which .eq. 'BE') then c c %------------------------------------------------% c | Sort the "converged" Ritz values in increasing | c | order. The "threshold" values are in the | c | middle. | c %------------------------------------------------% c wprime = 'LA' call dsortr(wprime, .true., nconv, ritz, bounds) c else c c %----------------------------------------------% c | In LM, SM, LA, SA case, sort the "converged" | c | Ritz values according to WHICH so that the | c | "threshold" value appears at the front of | c | ritz. | c %----------------------------------------------% call dsortr(which, .true., nconv, ritz, bounds) c end if c c %------------------------------------------% c | Use h( 1,1 ) as storage to communicate | c | rnorm to _seupd if needed | c %------------------------------------------% c h(1,1) = rnorm c if (msglvl .gt. 1) then call dvout (logfil, kplusp, ritz, ndigit, & '_saup2: Sorted Ritz values.') call dvout (logfil, kplusp, bounds, ndigit, & '_saup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. nev0) info = 2 c np = nconv go to 1100 c else if (nconv .lt. nev .and. ishift .eq. 1) then c c %---------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the number | c | of Ritz values and the shifts. | c %---------------------------------------------------% c nevbef = nev nev = nev + min (nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 2) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call dsgets (ishift, which, nev, np, ritz, bounds, & workl) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_saup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_saup2: NEV and NP are') call dvout (logfil, nev, ritz(np+1), ndigit, & '_saup2: "wanted" Ritz values.') call dvout (logfil, nev, bounds(np+1), ndigit, & '_saup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-----------------------------------------------------% c | User specified shifts: reverse communication to | c | compute the shifts. They are returned in the first | c | NP locations of WORKL. | c %-----------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if c 50 continue c c %------------------------------------% c | Back from reverse communication; | c | User specified shifts are returned | c | in WORKL(1:*NP) | c %------------------------------------% c ushift = .false. c c c %---------------------------------------------------------% c | Move the NP shifts to the first NP locations of RITZ to | c | free up WORKL. This is for the non-exact shift case; | c | in the exact shift case, dsgets already handles this. | c %---------------------------------------------------------% c if (ishift .eq. 0) call dcopy (np, workl, 1, ritz, 1) c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_saup2: The number of shifts to apply ') call dvout (logfil, np, workl, ndigit, & '_saup2: shifts selected') if (ishift .eq. 1) then call dvout (logfil, np, bounds, ndigit, & '_saup2: corresponding Ritz estimates') end if end if c c %---------------------------------------------------------% c | Apply the NP0 implicit shifts by QR bulge chasing. | c | Each shift is applied to the entire tridiagonal matrix. | c | The first 2*N locations of WORKD are used as workspace. | c | After dsapps is done, we have a Lanczos | c | factorization of length NEV. | c %---------------------------------------------------------% c call dsapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, & workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to dsaitr. | c %---------------------------------------------% c cnorm = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call dcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call dcopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = ddot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = dnrm2(n, resid, 1) end if cnorm = .false. 130 continue c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm, ndigit, & '_saup2: B-norm of residual for NEV factorization') call dvout (logfil, nev, h(1,2), ndigit, & '_saup2: main diagonal of compressed H matrix') call dvout (logfil, nev-1, h(2,1), ndigit, & '_saup2: subdiagonal of compressed H matrix') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = nconv c 1200 continue ido = 99 c c %------------% c | Error exit | c %------------% c call arscnd (t1) tsaup2 = t1 - t0 c 9000 continue return c c %---------------% c | End of dsaup2 | c %---------------% c end arpack-akloeckner-07/SRC/dsaupd.f0000644000175000017500000007060710670622032016561 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsaupd c c\Description: c c Reverse communication interface for the Implicitly Restarted Arnoldi c Iteration. For symmetric problems this reduces to a variant of the Lanczos c method. This method has been designed to compute approximations to a c few eigenpairs of a linear operator OP that is real and symmetric c with respect to a real positive semi-definite symmetric matrix B, c i.e. c c B*OP = (OP`)*B. c c Another way to express this condition is c c < x,OPy > = < OPx,y > where < z,w > = z`Bw . c c In the standard eigenproblem B is the identity matrix. c ( A` denotes transpose of A) c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c dsaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x, A symmetric c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite c ===> OP = (inv[K - sigma*M])*M and B = M. c ===> Shift-and-Invert mode c c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, c KG symmetric indefinite c ===> OP = (inv[K - sigma*KG])*K and B = K. c ===> Buckling mode c c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. c ===> Cayley transformed mode c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call dsaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to dsaupd . IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c dsaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c (If Mode = 2 see remark 5 below) c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3,4 and 5, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute the IPARAM(8) shifts where c IPNTR(11) is the pointer into WORKL for c placing the shifts. See remark 6 below. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c Specify which of the Ritz values of OP to compute. c c 'LA' - compute the NEV largest (algebraic) eigenvalues. c 'SA' - compute the NEV smallest (algebraic) eigenvalues. c 'LM' - compute the NEV largest (in magnitude) eigenvalues. c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. c 'BE' - compute NEV eigenvalues, half from each end of the c spectrum. When NEV is odd, compute one more from the c high end than from the low end. c (see remark 1 below) c c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N. c c TOL Double precision scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). c If TOL .LE. 0. is passed a default is set: c DEFAULT = DLAMCH ('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine DLAMCH ). c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V (less than or equal to N). c This will indicate how many Lanczos vectors are generated c at each iteration. After the startup phase in which NEV c Lanczos vectors are generated, the algorithm generates c NCV-NEV Lanczos vectors at each subsequent update iteration. c Most of the cost in generating each Lanczos vector is in the c matrix-vector product OP*x. (See remark 4 below). c c V Double precision N by NCV array. (OUTPUT) c The NCV columns of V contain the Lanczos basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are provided by the user via c reverse communication. The NCV eigenvalues of c the current tridiagonal matrix T are returned in c the part of WORKL array corresponding to RITZ. c See remark 6 below. c ISHIFT = 1: exact shifts with respect to the reduced c tridiagonal matrix T. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of Ritz vectors c associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = LEVEC c No longer referenced. See remark 2 below. c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4,5; See under \Description of dsaupd for the c five modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), dsaupd returns NP, the number c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark c 6 below. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 11. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Lanczos iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. c IPNTR(6): pointer to the NCV RITZ values array in WORKL. c IPNTR(7): pointer to the Ritz estimates in array WORKL associated c with the Ritz values located in RITZ in WORKL. c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. c c Note: IPNTR(8:10) is only referenced by dseupd . See Remark 2. c IPNTR(8): pointer to the NCV RITZ values of the original system. c IPNTR(9): pointer to the NCV corresponding error bounds. c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors c of the tridiagonal matrix T. Only referenced by c dseupd if RVEC = .TRUE. See Remarks. c ------------------------------------------------------------- c c WORKD Double precision work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration. Upon termination c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired c subroutine dseupd uses this output. c See Data Distribution Note below. c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least NCV**2 + 8*NCV . c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV must be greater than NEV and less than or equal to N. c = -4: The maximum number of Arnoldi update iterations allowed c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array WORKL is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Informatinal error from LAPACK routine dsteqr . c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. c = -12: IPARAM(1) must be equal to 0 or 1. c = -13: NEV and WHICH = 'BE' are incompatable. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current Arnoldi c factorization. The user is advised to check that c enough workspace and array storage has been allocated. c c c\Remarks c 1. The converged Ritz values are always returned in ascending c algebraic order. The computed Ritz values are approximate c eigenvalues of OP. The selection of WHICH should be made c with this in mind when Mode = 3,4,5. After convergence, c approximate eigenvalues of the original problem may be obtained c with the ARPACK subroutine dseupd . c c 2. If the Ritz vectors corresponding to the converged Ritz values c are needed, the user must call dseupd immediately following completion c of dsaupd . This is new starting with version 2.1 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requrement is that NCV > NEV. c However, it is recommended that NCV .ge. 2*NEV. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user c must do the following. When IDO = 1, Y = OP * X is to be computed. c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user c must overwrite X with A*X. Y is then the solution to the linear set c of equations B*Y = A*X. c c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) shifts in locations: c 1 WORKL(IPNTR(11)) c 2 WORKL(IPNTR(11)+1) c . c . c . c NP WORKL(IPNTR(11)+NP-1). c c The eigenvalues of the current tridiagonal matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the c order defined by WHICH. The associated Ritz estimates are located in c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) c DECOMPOSE D1(N), D2(N,NCV) c ALIGN RESID(I) with D1(I) c ALIGN V(I,J) with D2(I,J) c ALIGN WORKD(I) with D1(I) range (1:N) c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) c REPLICATED WORKL(LWORKL) c c Cray MPP syntax: c =============== c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) c REPLICATED WORKL(LWORKL) c c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral c Transformations in a k-Step Arnoldi Method". In Preparation. c c\Routines called: c dsaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c dstats ARPACK routine that initialize timing and other statistics c variables. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine dsaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(11) Double precision & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0 , zero = 0.0D+0 ) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, msglvl, mxiter, mode, nb, & nev0, next, np, ritz, j save bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, msglvl, mxiter, mode, nb, & nev0, next, np, ritz c c %----------------------% c | External Subroutines | c %----------------------% c external dsaup2 , dvout , ivout, arscnd, dstats c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch external dlamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call dstats call arscnd (t0) msglvl = msaupd c ierr = 0 ishift = iparam(1) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c c %----------------% c | Error checking | c %----------------% c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 end if c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c %----------------------------------------------% c np = ncv - nev c if (mxiter .le. 0) ierr = -4 if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LA' .and. & which .ne. 'SA' .and. & which .ne. 'BE') ierr = -5 if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 c if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 if (mode .lt. 1 .or. mode .gt. 5) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 else if (ishift .lt. 0 .or. ishift .gt. 1) then ierr = -12 else if (nev .eq. 1 .and. which .eq. 'BE') then ierr = -13 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. zero) tol = dlamch ('EpsMach') c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, ncv**2 + 8*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:2*ncv) := generated tridiagonal matrix | c | workl(2*ncv+1:2*ncv+ncv) := ritz values | c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | c %-------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritz = ih + 2*ldh bounds = ritz + ncv iq = bounds + ncv iw = iq + ncv**2 next = iw + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritz ipntr(7) = bounds ipntr(11) = iw end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Lanczos Iteration. | c %-------------------------------------------------------% c call dsaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, & info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP or shifts. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within dsaup2 . | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_saupd: number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_saupd: number of "converged" Ritz values') call dvout (logfil, np, workl(Ritz), ndigit, & '_saupd: final Ritz values') call dvout (logfil, np, workl(Bounds), ndigit, & '_saupd: corresponding error bounds') end if c call arscnd (t1) tsaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, & tgetv0, tseigt, tsgets, tsapps, tsconv 1000 format (//, & 5x, '==========================================',/ & 5x, '= Symmetric implicit Arnoldi update code =',/ & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ & 5x, '==========================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '==========================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in saup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6) end if c 9000 continue c return c c %---------------% c | End of dsaupd | c %---------------% c end arpack-akloeckner-07/SRC/dsconv.f0000644000175000017500000000660210670622032016567 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsconv c c\Description: c Convergence testing for the symmetric Arnoldi eigenvalue routine. c c\Usage: c call dsconv c ( N, RITZ, BOUNDS, TOL, NCONV ) c c\Arguments c N Integer. (INPUT) c Number of Ritz values to check for convergence. c c RITZ Double precision array of length N. (INPUT) c The Ritz values to be checked for convergence. c c BOUNDS Double precision array of length N. (INPUT) c Ritz estimates associated with the Ritz values in RITZ. c c TOL Double precision scalar. (INPUT) c Desired relative accuracy for a Ritz value to be considered c "converged". c c NCONV Integer scalar. (OUTPUT) c Number of "converged" Ritz values. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines called: c arscnd ARPACK utility routine for timing. c dlamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 c c\Remarks c 1. Starting with version 2.4, this routine no longer uses the c Parlett strategy using the gap conditions. c c\EndLib c c----------------------------------------------------------------------- c subroutine dsconv (n, ritz, bounds, tol, nconv) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer n, nconv Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & ritz(n), bounds(n) c c %---------------% c | Local Scalars | c %---------------% c integer i Double precision & temp, eps23 c c %-------------------% c | External routines | c %-------------------% c Double precision & dlamch external dlamch c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c call arscnd (t0) c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0) c nconv = 0 do 10 i = 1, n c c %-----------------------------------------------------% c | The i-th Ritz value is considered "converged" | c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | c %-----------------------------------------------------% c temp = max( eps23, abs(ritz(i)) ) if ( bounds(i) .le. tol*temp ) then nconv = nconv + 1 end if c 10 continue c call arscnd (t1) tsconv = tsconv + (t1 - t0) c return c c %---------------% c | End of dsconv | c %---------------% c end arpack-akloeckner-07/SRC/dseigt.f0000644000175000017500000001211510670622032016546 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dseigt c c\Description: c Compute the eigenvalues of the current symmetric tridiagonal matrix c and the corresponding error bounds given the current residual norm. c c\Usage: c call dseigt c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) c c\Arguments c RNORM Double precision scalar. (INPUT) c RNORM contains the residual norm corresponding to the current c symmetric tridiagonal matrix H. c c N Integer. (INPUT) c Size of the symmetric tridiagonal matrix H. c c H Double precision N by 2 array. (INPUT) c H contains the symmetric tridiagonal matrix with the c subdiagonal in the first column starting at H(2,1) and the c main diagonal in second column. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c EIG Double precision array of length N. (OUTPUT) c On output, EIG contains the N eigenvalues of H possibly c unsorted. The BOUNDS arrays are returned in the c same sorted order as EIG. c c BOUNDS Double precision array of length N. (OUTPUT) c On output, BOUNDS contains the error estimates corresponding c to the eigenvalues EIG. This is equal to RNORM times the c last components of the eigenvectors corresponding to the c eigenvalues in EIG. c c WORKL Double precision work array of length 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c IERR Integer. (OUTPUT) c Error exit flag from dstqrb. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dstqrb ARPACK routine that computes the eigenvalues and the c last components of the eigenvectors of a symmetric c and tridiagonal matrix. c arscnd ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dcopy Level 1 BLAS that copies one vector to another. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine dseigt & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, ldh, n Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & eig(n), bounds(n), h(ldh,2), workl(3*n) c c %------------% c | Parameters | c %------------% c Double precision & zero parameter (zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c integer i, k, msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy, dstqrb, dvout, arscnd c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mseigt c if (msglvl .gt. 0) then call dvout (logfil, n, h(1,2), ndigit, & '_seigt: main diagonal of matrix H') if (n .gt. 1) then call dvout (logfil, n-1, h(2,1), ndigit, & '_seigt: sub diagonal of matrix H') end if end if c call dcopy (n, h(1,2), 1, eig, 1) call dcopy (n-1, h(2,1), 1, workl, 1) call dstqrb (n, eig, workl, bounds, workl(n+1), ierr) if (ierr .ne. 0) go to 9000 if (msglvl .gt. 1) then call dvout (logfil, n, bounds, ndigit, & '_seigt: last row of the eigenvector matrix for H') end if c c %-----------------------------------------------% c | Finally determine the error bounds associated | c | with the n Ritz values of H. | c %-----------------------------------------------% c do 30 k = 1, n bounds(k) = rnorm*abs(bounds(k)) 30 continue c call arscnd (t1) tseigt = tseigt + (t1 - t0) c 9000 continue return c c %---------------% c | End of dseigt | c %---------------% c end arpack-akloeckner-07/SRC/ssesrt.f0000644000175000017500000001231006136210160016604 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssesrt c c\Description: c Sort the array X in the order specified by WHICH and optionally c apply the permutation to the columns of the matrix A. c c\Usage: c call ssesrt c ( WHICH, APPLY, N, X, NA, A, LDA) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> X is sorted into increasing order of magnitude. c 'SM' -> X is sorted into decreasing order of magnitude. c 'LA' -> X is sorted into increasing order of algebraic. c 'SA' -> X is sorted into decreasing order of algebraic. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to A. c APPLY = .FALSE. -> do not apply the sorted order to A. c c N Integer. (INPUT) c Dimension of the array X. c c X Real array of length N. (INPUT/OUTPUT) c The array to be sorted. c c NA Integer. (INPUT) c Number of rows of the matrix A. c c A Real array of length NA by N. (INPUT/OUTPUT) c c LDA Integer. (INPUT) c Leading dimension of A. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines c sswap Level 1 BLAS that swaps the contents of two vectors. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.1'. c Adapted from the sort routine in LANSO and c the ARPACK code ssortr c c\SCCS Information: @(#) c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine ssesrt (which, apply, n, x, na, a, lda) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer lda, n, na c c %-----------------% c | Array Arguments | c %-----------------% c Real & x(0:n-1), a(lda, 0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Real & temp c c %----------------------% c | External Subroutines | c %----------------------% c external sswap c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'SA') then c c X is sorted into decreasing order of algebraic. c 10 continue if (igap .eq. 0) go to 9000 do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c if (x(j).lt.x(j+igap)) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 30 endif j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c X is sorted into decreasing order of magnitude. c 40 continue if (igap .eq. 0) go to 9000 do 60 i = igap, n-1 j = i-igap 50 continue c if (j.lt.0) go to 60 c if (abs(x(j)).lt.abs(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LA') then c c X is sorted into increasing order of algebraic. c 70 continue if (igap .eq. 0) go to 9000 do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (x(j).gt.x(j+igap)) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'LM') then c c X is sorted into increasing order of magnitude. c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (abs(x(j)).gt.abs(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call sswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 end if c 9000 continue return c c %---------------% c | End of ssesrt | c %---------------% c end arpack-akloeckner-07/SRC/dsgets.f0000644000175000017500000001643510670622032016571 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsgets c c\Description: c Given the eigenvalues of the symmetric tridiagonal matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: This is called even in the case of user specified shifts in c order to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call dsgets c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> KEV eigenvalues of largest magnitude are retained. c 'SM' -> KEV eigenvalues of smallest magnitude are retained. c 'LA' -> KEV eigenvalues of largest value are retained. c 'SA' -> KEV eigenvalues of smallest value are retained. c 'BE' -> KEV eigenvalues, half from each end of the spectrum. c If KEV is odd, compute one more from the high end. c c KEV Integer. (INPUT) c KEV+NP is the size of the matrix H. c c NP Integer. (INPUT) c Number of implicit shifts to be computed. c c RITZ Double precision array of length KEV+NP. (INPUT/OUTPUT) c On INPUT, RITZ contains the eigenvalues of H. c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues c are in the first NP locations and the wanted part is in c the last KEV locations. When exact shifts are selected, the c unwanted part corresponds to the shifts to be applied. c c BOUNDS Double precision array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c SHIFTS Double precision array of length NP. (INPUT/OUTPUT) c On INPUT: contains the user specified shifts if ISHIFT = 0. c On OUTPUT: contains the shifts sorted into decreasing order c of magnitude with respect to the Ritz estimates contained in c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c dsortr ARPACK utility sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c dvout ARPACK utility routine that prints vectors. c dcopy Level 1 BLAS that copies one vector to another. c dswap Level 1 BLAS that swaps the contents of two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/93: Version ' 2.1' c c\SCCS Information: @(#) c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine dsgets ( ishift, which, kev, np, ritz, bounds, shifts ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & bounds(kev+np), ritz(kev+np), shifts(np) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %---------------% c | Local Scalars | c %---------------% c integer kevd2, msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external dswap, dcopy, dsortr, arscnd c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic max, min c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = msgets c if (which .eq. 'BE') then c c %-----------------------------------------------------% c | Both ends of the spectrum are requested. | c | Sort the eigenvalues into algebraically increasing | c | order first then swap high end of the spectrum next | c | to low end in appropriate locations. | c | NOTE: when np < floor(kev/2) be careful not to swap | c | overlapping locations. | c %-----------------------------------------------------% c call dsortr ('LA', .true., kev+np, ritz, bounds) kevd2 = kev / 2 if ( kev .gt. 1 ) then call dswap ( min(kevd2,np), ritz, 1, & ritz( max(kevd2,np)+1 ), 1) call dswap ( min(kevd2,np), bounds, 1, & bounds( max(kevd2,np)+1 ), 1) end if c else c c %----------------------------------------------------% c | LM, SM, LA, SA case. | c | Sort the eigenvalues of H into the desired order | c | and apply the resulting order to BOUNDS. | c | The eigenvalues are sorted so that the wanted part | c | are always in the last KEV locations. | c %----------------------------------------------------% c call dsortr (which, .true., kev+np, ritz, bounds) end if c if (ishift .eq. 1 .and. np .gt. 0) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first. | c | This will tend to minimize the effects of the | c | forward instability of the iteration when the shifts | c | are applied in subroutine dsapps. | c %-------------------------------------------------------% c call dsortr ('SM', .true., np, bounds, ritz) call dcopy (np, ritz, 1, shifts, 1) end if c call arscnd (t1) tsgets = tsgets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is') call ivout (logfil, 1, np, ndigit, '_sgets: NP is') call dvout (logfil, kev+np, ritz, ndigit, & '_sgets: Eigenvalues of current H matrix') call dvout (logfil, kev+np, bounds, ndigit, & '_sgets: Associated Ritz estimates') end if c return c c %---------------% c | End of dsgets | c %---------------% c end arpack-akloeckner-07/SRC/dsortc.f0000644000175000017500000002204606136210142016566 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsortc c c\Description: c Sorts the complex array in XREAL and XIMAG into the order c specified by WHICH and optionally applies the permutation to the c real array Y. It is assumed that if an element of XIMAG is c nonzero, then its negative is also an element. In other words, c both members of a complex conjugate pair are to be sorted and the c pairs are kept adjacent to each other. c c\Usage: c call dsortc c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. c 'LR' -> sort XREAL into increasing order of algebraic. c 'SR' -> sort XREAL into decreasing order of algebraic. c 'LI' -> sort XIMAG into increasing order of magnitude. c 'SI' -> sort XIMAG into decreasing order of magnitude. c NOTE: If an element of XIMAG is non-zero, then its negative c is also an element. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to array Y. c APPLY = .FALSE. -> do not apply the sorted order to array Y. c c N Integer. (INPUT) c Size of the arrays. c c XREAL, Double precision array of length N. (INPUT/OUTPUT) c XIMAG Real and imaginary part of the array to be sorted. c c Y Double precision array of length N. (INPUT/OUTPUT) c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dsortc (which, apply, n, xreal, ximag, y) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & xreal(0:n-1), ximag(0:n-1), y(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Double precision & temp, temp1, temp2 c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlapy2 external dlapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'LM') then c c %------------------------------------------------------% c | Sort XREAL,XIMAG into increasing order of magnitude. | c %------------------------------------------------------% c 10 continue if (igap .eq. 0) go to 9000 c do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c temp1 = dlapy2(xreal(j),ximag(j)) temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) c if (temp1.gt.temp2) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 30 end if j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c %------------------------------------------------------% c | Sort XREAL,XIMAG into decreasing order of magnitude. | c %------------------------------------------------------% c 40 continue if (igap .eq. 0) go to 9000 c do 60 i = igap, n-1 j = i-igap 50 continue c if (j .lt. 0) go to 60 c temp1 = dlapy2(xreal(j),ximag(j)) temp2 = dlapy2(xreal(j+igap),ximag(j+igap)) c if (temp1.lt.temp2) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LR') then c c %------------------------------------------------% c | Sort XREAL into increasing order of algebraic. | c %------------------------------------------------% c 70 continue if (igap .eq. 0) go to 9000 c do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (xreal(j).gt.xreal(j+igap)) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'SR') then c c %------------------------------------------------% c | Sort XREAL into decreasing order of algebraic. | c %------------------------------------------------% c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (xreal(j).lt.xreal(j+igap)) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 c else if (which .eq. 'LI') then c c %------------------------------------------------% c | Sort XIMAG into increasing order of magnitude. | c %------------------------------------------------% c 130 continue if (igap .eq. 0) go to 9000 do 150 i = igap, n-1 j = i-igap 140 continue c if (j.lt.0) go to 150 c if (abs(ximag(j)).gt.abs(ximag(j+igap))) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 150 endif j = j-igap go to 140 150 continue igap = igap / 2 go to 130 c else if (which .eq. 'SI') then c c %------------------------------------------------% c | Sort XIMAG into decreasing order of magnitude. | c %------------------------------------------------% c 160 continue if (igap .eq. 0) go to 9000 do 180 i = igap, n-1 j = i-igap 170 continue c if (j.lt.0) go to 180 c if (abs(ximag(j)).lt.abs(ximag(j+igap))) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 180 endif j = j-igap go to 170 180 continue igap = igap / 2 go to 160 end if c 9000 continue return c c %---------------% c | End of dsortc | c %---------------% c end arpack-akloeckner-07/SRC/dsortr.f0000644000175000017500000001235406136210143016607 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsortr c c\Description: c Sort the array X1 in the order specified by WHICH and optionally c applies the permutation to the array X2. c c\Usage: c call dsortr c ( WHICH, APPLY, N, X1, X2 ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> X1 is sorted into increasing order of magnitude. c 'SM' -> X1 is sorted into decreasing order of magnitude. c 'LA' -> X1 is sorted into increasing order of algebraic. c 'SA' -> X1 is sorted into decreasing order of algebraic. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to X2. c APPLY = .FALSE. -> do not apply the sorted order to X2. c c N Integer. (INPUT) c Size of the arrays. c c X1 Double precision array of length N. (INPUT/OUTPUT) c The array to be sorted. c c X2 Double precision array of length N. (INPUT/OUTPUT) c Only referenced if APPLY = .TRUE. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version ' 2.1'. c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dsortr (which, apply, n, x1, x2) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & x1(0:n-1), x2(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Double precision & temp c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'SA') then c c X1 is sorted into decreasing order of algebraic. c 10 continue if (igap .eq. 0) go to 9000 do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c if (x1(j).lt.x1(j+igap)) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 30 endif j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c X1 is sorted into decreasing order of magnitude. c 40 continue if (igap .eq. 0) go to 9000 do 60 i = igap, n-1 j = i-igap 50 continue c if (j.lt.0) go to 60 c if (abs(x1(j)).lt.abs(x1(j+igap))) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LA') then c c X1 is sorted into increasing order of algebraic. c 70 continue if (igap .eq. 0) go to 9000 do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (x1(j).gt.x1(j+igap)) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'LM') then c c X1 is sorted into increasing order of magnitude. c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (abs(x1(j)).gt.abs(x1(j+igap))) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 end if c 9000 continue return c c %---------------% c | End of dsortr | c %---------------% c end arpack-akloeckner-07/SRC/dstatn.f0000644000175000017500000000271006136210144016563 0ustar andreasandreasc c %---------------------------------------------% c | Initialize statistic and timing information | c | for nonsymmetric Arnoldi code. | c %---------------------------------------------% c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 c subroutine dstatn c c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c include 'stat.h' c c %-----------------------% c | Executable Statements | c %-----------------------% c nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 c tnaupd = 0.0D+0 tnaup2 = 0.0D+0 tnaitr = 0.0D+0 tneigh = 0.0D+0 tngets = 0.0D+0 tnapps = 0.0D+0 tnconv = 0.0D+0 titref = 0.0D+0 tgetv0 = 0.0D+0 trvec = 0.0D+0 c c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% c tmvopx = 0.0D+0 tmvbx = 0.0D+0 c return c c c %---------------% c | End of dstatn | c %---------------% c end arpack-akloeckner-07/SRC/dstats.f0000644000175000017500000000221606136210144016571 0ustar andreasandreasc c\SCCS Information: @(#) c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 c %---------------------------------------------% c | Initialize statistic and timing information | c | for symmetric Arnoldi code. | c %---------------------------------------------% subroutine dstats c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% include 'stat.h' c %-----------------------% c | Executable Statements | c %-----------------------% nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 tsaupd = 0.0D+0 tsaup2 = 0.0D+0 tsaitr = 0.0D+0 tseigt = 0.0D+0 tsgets = 0.0D+0 tsapps = 0.0D+0 tsconv = 0.0D+0 titref = 0.0D+0 tgetv0 = 0.0D+0 trvec = 0.0D+0 c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% tmvopx = 0.0D+0 tmvbx = 0.0D+0 return c c End of dstats c end arpack-akloeckner-07/SRC/sneupd.f0000644000175000017500000012577507162222372016613 0ustar andreasandreasc\BeginDoc c c\Name: sneupd c c\Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are derived from approximate eigenvalues and eigenvectors of c of the linear operator OP prescribed by the MODE selection in the c call to SNAUPD. SNAUPD must be called before this routine is called. c These approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c See documentation in the header of the subroutine SNAUPD for c definition of OP as well as other terms and the relation of computed c Ritz values and Ritz vectors of OP with respect to the given problem c A*z = lambda*B*z. For a brief description, see definitions of c IPARAM(7), MODE and WHICH in the documentation of SNAUPD. c c\Usage: c call sneupd c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, WORKEV, BMAT, c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, c LWORKL, INFO ) c c\Arguments: c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. c c DR Real array of dimension NEV+1. (OUTPUT) c If IPARAM(7) = 1,2 or 3 and SIGMAI=0.0 then on exit: DR contains c the real part of the Ritz approximations to the eigenvalues of c A*z = lambda*B*z. c If IPARAM(7) = 3, 4 and SIGMAI is not equal to zero, then on exit: c DR contains the real part of the Ritz values of OP computed by c SNAUPD. A further computation must be performed by the user c to transform the Ritz values computed for OP by SNAUPD to those c of the original system A*z = lambda*B*z. See remark 3 below. c c DI Real array of dimension NEV+1. (OUTPUT) c On exit, DI contains the imaginary part of the Ritz value c approximations to the eigenvalues of A*z = lambda*B*z associated c with DR. c c NOTE: When Ritz values are complex, they will come in complex c conjugate pairs. If eigenvectors are requested, the c corresponding Ritz vectors will also come in conjugate c pairs and the real and imaginary parts of these are c represented in two consecutive columns of the array Z c (see below). c c Z Real N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represent approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c The complex Ritz vector associated with the Ritz value c with positive imaginary part is stored in two consecutive c columns. The first column holds the real part of the Ritz c vector and the second column holds the imaginary part. The c Ritz vector associated with the Ritz value with negative c imaginary part is simply the complex conjugate of the Ritz vector c associated with the positive imaginary part. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by SNAUPD. In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. c c SIGMAR Real (INPUT) c If IPARAM(7) = 3 or 4, represents the real part of the shift. c Not referenced if IPARAM(7) = 1 or 2. c c SIGMAI Real (INPUT) c If IPARAM(7) = 3 or 4, represents the imaginary part of the shift. c Not referenced if IPARAM(7) = 1 or 2. See remark 3 below. c c WORKEV Real work array of dimension 3*NCV. (WORKSPACE) c c **** The remaining arguments MUST be the same as for the **** c **** call to SNAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, INFO c c must be passed directly to SNEUPD following the last call c to SNAUPD. These arguments MUST NOT BE MODIFIED between c the the last call to SNAUPD and the call to SNEUPD. c c Three of these parameters (V, WORKL, INFO) are also output parameters: c c V Real N by NCV array. (INPUT/OUTPUT) c c Upon INPUT: the NCV columns of V contain the Arnoldi basis c vectors for OP as constructed by SNAUPD . c c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. See Remark 2 below. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the c Arnoldi basis held by V has been overwritten by the desired c Ritz vectors. If a separate array Z has been passed then c the first NCONV=IPARAM(5) columns of V will contain approximate c Schur vectors that span the desired invariant subspace. c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:ncv*ncv+3*ncv) contains information obtained in c snaupd. They are not changed by sneupd. c WORKL(ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) holds the c real and imaginary part of the untransformed Ritz values, c the upper quasi-triangular matrix for H, and the c associated matrix representation of the invariant subspace for H. c c Note: IPNTR(9:13) contains the pointer into WORKL for addresses c of the above information computed by sneupd. c ------------------------------------------------------------- c IPNTR(9): pointer to the real part of the NCV RITZ values of the c original system. c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of c the original system. c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c sneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c c = 0: Normal exit. c c = 1: The Schur form computed by LAPACK routine slahqr c could not be reordered by LAPACK routine strsen. c Re-enter subroutine sneupd with IPARAM(5)=NCV and c increase the size of the arrays DR and DI to have c dimension at least dimension NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors if this error c occurs. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from calculation of a real Schur form. c Informational error from LAPACK routine slahqr. c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine strevc. c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: SNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: DNEUPD got a different count of the number of converged c Ritz values than DNAUPD got. This indicates the user c probably made an error in passing data from DNAUPD to c DNEUPD or that the data was modified before entering c DNEUPD c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c ivout ARPACK utility routine that prints integers. c smout ARPACK utility routine that prints matrices c svout ARPACK utility routine that prints vectors. c sgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c slacpy LAPACK matrix copy routine. c slahqr LAPACK routine to compute the real Schur form of an c upper Hessenberg matrix. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK matrix initialization routine. c sorm2r LAPACK routine that applies an orthogonal matrix in c factored form. c strevc LAPACK routine to compute the eigenvectors of a matrix c in upper quasi-triangular form. c strsen LAPACK routine that re-orders the Schur form. c strmm Level 3 BLAS matrix times an upper triangular matrix. c sger Level 2 BLAS rank one update to a matrix. c scopy Level 1 BLAS that copies one vector to another . c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c sscal Level 1 BLAS that scales a vector. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c Let trans(X) denote the transpose of X. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .TRUE. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c trans(V(:,1:IPARAM(5))) * V(:,1:IPARAM(5)) = I are approximately c satisfied. Here T is the leading submatrix of order IPARAM(5) of the c real upper quasi-triangular matrix stored workl(ipntr(12)). That is, c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; c each 2-by-2 diagonal block has its diagonal elements equal and its c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 c diagonal block is a complex conjugate pair of Ritz values. The real c Ritz values are stored on the diagonal of T. c c 3. If IPARAM(7) = 3 or 4 and SIGMAI is not equal zero, then the user must c form the IPARAM(5) Rayleigh quotients in order to transform the Ritz c values computed by SNAUPD for OP to those of A*z = lambda*B*z. c Set RVEC = .true. and HOWMNY = 'A', and c compute c trans(Z(:,I)) * A * Z(:,I) if DI(I) = 0. c If DI(I) is not equal to zero and DI(I+1) = - D(I), c then the desired real and imaginary parts of the Ritz value are c trans(Z(:,I)) * A * Z(:,I) + trans(Z(:,I+1)) * A * Z(:,I+1), c trans(Z(:,I)) * A * Z(:,I+1) - trans(Z(:,I+1)) * A * Z(:,I), c respectively. c Another possibility is to set RVEC = .true. and HOWMNY = 'P' and c compute trans(V(:,1:IPARAM(5))) * A * V(:,1:IPARAM(5)) and then an upper c quasi-triangular matrix of order IPARAM(5) is computed. See remark c 2 above. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neupd.F SID: 2.7 DATE OF SID: 09/20/00 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine sneupd(rvec , howmny, select, dr , di, & z , ldz , sigmar, sigmai, workev, & bmat , n , which , nev , tol, & resid, ncv , v , ldv , iparam, & ipntr, workd , workl , lworkl, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Real & sigmar, sigmai, tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) logical select(ncv) Real & dr(nev+1) , di(nev+1), resid(n) , & v(ldv,ncv) , z(ldz,*) , workd(3*n), & workl(lworkl), workev(3*ncv) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0 , zero = 0.0E+0 ) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds, ierr , ih , ihbds , & iheigr, iheigi, iconj , nconv , & invsub, iuptri, iwev , iwork(1), & j , k , ldh , ldq , & mode , msglvl, outncv, ritzr , & ritzi , wri , wrr , irr , & iri , ibd , ishift, numcnv , & np , jj logical reord Real & conds , rnorm, sep , temp, & vl(1,1), temp1, eps23 c c %----------------------% c | External Subroutines | c %----------------------% c external scopy , sger , sgeqr2, slacpy, & slahqr, slaset, smout , sorm2r, & strevc, strmm , strsen, sscal , & svout , ivout c c %--------------------% c | External Functions | c %--------------------% c Real & slapy2, snrm2, slamch, sdot external slapy2, snrm2, slamch, sdot c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, min, sqrt c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mneupd mode = iparam(7) nconv = iparam(5) info = 0 c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0 ) c c %--------------% c | Quick return | c %--------------% c ierr = 0 c if (nconv .le. 0) then ierr = -14 else if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev+1 .or. ncv .gt. n) then ierr = -3 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 6*ncv) then ierr = -7 else if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) then ierr = -13 else if (howmny .eq. 'S' ) then ierr = -12 end if c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 .and. sigmai .eq. zero) then type = 'SHIFTI' else if (mode .eq. 3 ) then type = 'REALPT' else if (mode .eq. 4 ) then type = 'IMAGPT' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %--------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | c | parts of ritz values | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | c %--------------------------------------------------------% c c %-----------------------------------------------------------% c | The following is used and set by SNEUPD. | c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | c | real part of the Ritz values. | c | workl(ncv*ncv+4*ncv+1:ncv*ncv+5*ncv) := The untransformed | c | imaginary part of the Ritz values. | c | workl(ncv*ncv+5*ncv+1:ncv*ncv+6*ncv) := The untransformed | c | error bounds of the Ritz values | c | workl(ncv*ncv+6*ncv+1:2*ncv*ncv+6*ncv) := Holds the upper | c | quasi-triangular matrix for H | c | workl(2*ncv*ncv+6*ncv+1: 3*ncv*ncv+6*ncv) := Holds the | c | associated matrix representation of the invariant | c | subspace for H. | c | GRAND total of NCV * ( 3 * NCV + 6 ) locations. | c %-----------------------------------------------------------% c ih = ipntr(5) ritzr = ipntr(6) ritzi = ipntr(7) bounds = ipntr(8) ldh = ncv ldq = ncv iheigr = bounds + ldh iheigi = iheigr + ldh ihbds = iheigi + ldh iuptri = ihbds + ldh invsub = iuptri + ldh*ncv ipntr(9) = iheigr ipntr(10) = iheigi ipntr(11) = ihbds ipntr(12) = iuptri ipntr(13) = invsub wrr = 1 wri = ncv + 1 iwev = wri + ncv c c %-----------------------------------------% c | irr points to the REAL part of the Ritz | c | values computed by _neigh before | c | exiting _naup2. | c | iri points to the IMAGINARY part of the | c | Ritz values computed by _neigh | c | before exiting _naup2. | c | ibd points to the Ritz estimates | c | computed by _neigh before exiting | c | _naup2. | c %-----------------------------------------% c irr = ipntr(14)+ncv*ncv iri = irr+ncv ibd = iri+ncv c c %------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c %------------------------------------% c rnorm = workl(ih+2) workl(ih+2) = zero c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(irr), ndigit, & '_neupd: Real part of Ritz values passed in from _NAUPD.') call svout(logfil, ncv, workl(iri), ndigit, & '_neupd: Imag part of Ritz values passed in from _NAUPD.') call svout(logfil, ncv, workl(ibd), ndigit, & '_neupd: Ritz estimates passed in from _NAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(bound) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call sngets(ishift , which , nev , & np , workl(irr), workl(iri), & workl(bounds), workl , workl(np+1)) c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(irr), ndigit, & '_neupd: Real part of Ritz values after calling _NGETS.') call svout(logfil, ncv, workl(iri), ndigit, & '_neupd: Imag part of Ritz values after calling _NGETS.') call svout(logfil, ncv, workl(bounds), ndigit, & '_neupd: Ritz value indices after calling _NGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv temp1 = max(eps23, & slapy2( workl(irr+ncv-j), workl(iri+ncv-j) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & workl(ibd+jj-1) .le. tol*temp1) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by dnaupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the dnaupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_neupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_neupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -15 go to 9000 end if c c %-----------------------------------------------------------% c | Call LAPACK routine slahqr to compute the real Schur form | c | of the upper Hessenberg matrix returned by SNAUPD. | c | Make a copy of the upper Hessenberg matrix. | c | Initialize the Schur vector matrix Q to the identity. | c %-----------------------------------------------------------% c call scopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) call slaset('All', ncv, ncv, & zero , one, workl(invsub), & ldq) call slahqr(.true., .true. , ncv, & 1 , ncv , workl(iuptri), & ldh , workl(iheigr), workl(iheigi), & 1 , ncv , workl(invsub), & ldq , ierr) call scopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call svout(logfil, ncv, workl(iheigr), ndigit, & '_neupd: Real part of the eigenvalues of H') call svout(logfil, ncv, workl(iheigi), ndigit, & '_neupd: Imaginary part of the Eigenvalues of H') call svout(logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the Schur vector matrix') if (msglvl .gt. 3) then call smout(logfil , ncv, ncv , & workl(iuptri), ldh, ndigit, & '_neupd: The upper quasi-triangular matrix ') end if end if c if (reord) then c c %-----------------------------------------------------% c | Reorder the computed upper quasi-triangular matrix. | c %-----------------------------------------------------% c call strsen('None' , 'V' , & select , ncv , & workl(iuptri), ldh , & workl(invsub), ldq , & workl(iheigr), workl(iheigi), & nconv , conds , & sep , workl(ihbds) , & ncv , iwork , & 1 , ierr) c if (ierr .eq. 1) then info = 1 go to 9000 end if c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(iheigr), ndigit, & '_neupd: Real part of the eigenvalues of H--reordered') call svout(logfil, ncv, workl(iheigi), ndigit, & '_neupd: Imag part of the eigenvalues of H--reordered') if (msglvl .gt. 3) then call smout(logfil , ncv, ncv , & workl(iuptri), ldq, ndigit, & '_neupd: Quasi-triangular matrix after re-ordering') end if end if c end if c c %---------------------------------------% c | Copy the last row of the Schur vector | c | into workl(ihbds). This will be used | c | to compute the Ritz estimates of | c | converged Ritz values. | c %---------------------------------------% c call scopy(ncv, workl(invsub+ncv-1), ldq, workl(ihbds), 1) c c %----------------------------------------------------% c | Place the computed eigenvalues of H into DR and DI | c | if a spectral transformation was not used. | c %----------------------------------------------------% c if (type .eq. 'REGULR') then call scopy(nconv, workl(iheigr), 1, dr, 1) call scopy(nconv, workl(iheigi), 1, di, 1) end if c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(invsub,ldq). | c %----------------------------------------------------------% c call sgeqr2(ncv, nconv , workl(invsub), & ldq, workev, workev(ncv+1), & ierr) c c %---------------------------------------------------------% c | * Postmultiply V by Q using sorm2r. | c | * Copy the first NCONV columns of VQ into Z. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(iheigr) and workl(iheigi) | c | The first NCONV columns of V are now approximate Schur | c | vectors associated with the real upper quasi-triangular | c | matrix of order NCONV in workl(iuptri) | c %---------------------------------------------------------% c call sorm2r('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , v , & ldv , workd(n+1) , ierr) call slacpy('All', n, nconv, v, ldv, z, ldz) c do 20 j=1, nconv c c %---------------------------------------------------% c | Perform both a column and row scaling if the | c | diagonal element of workl(invsub,ldq) is negative | c | I'm lazy and don't take advantage of the upper | c | quasi-triangular form of workl(iuptri,ldq) | c | Note that since Q is orthogonal, R is a diagonal | c | matrix consisting of plus or minus ones | c %---------------------------------------------------% c if (workl(invsub+(j-1)*ldq+j-1) .lt. zero) then call sscal(nconv, -one, workl(iuptri+j-1), ldq) call sscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) end if c 20 continue c if (howmny .eq. 'A') then c c %--------------------------------------------% c | Compute the NCONV wanted eigenvectors of T | c | located in workl(iuptri,ldq). | c %--------------------------------------------% c do 30 j=1, ncv if (j .le. nconv) then select(j) = .true. else select(j) = .false. end if 30 continue c call strevc('Right', 'Select' , select , & ncv , workl(iuptri), ldq , & vl , 1 , workl(invsub), & ldq , ncv , outncv , & workev , ierr) c if (ierr .ne. 0) then info = -9 go to 9000 end if c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | strevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; | c %------------------------------------------------% c iconj = 0 do 40 j=1, nconv c if ( workl(iheigi+j-1) .eq. zero ) then c c %----------------------% c | real eigenvalue case | c %----------------------% c temp = snrm2( ncv, workl(invsub+(j-1)*ldq), 1 ) call sscal( ncv, one / temp, & workl(invsub+(j-1)*ldq), 1 ) c else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we further normalize by the | c | square root of two. | c %-------------------------------------------% c if (iconj .eq. 0) then temp = slapy2(snrm2(ncv, & workl(invsub+(j-1)*ldq), & 1), & snrm2(ncv, & workl(invsub+j*ldq), & 1)) call sscal(ncv, one/temp, & workl(invsub+(j-1)*ldq), 1 ) call sscal(ncv, one/temp, & workl(invsub+j*ldq), 1 ) iconj = 1 else iconj = 0 end if c end if c 40 continue c call sgemv('T', ncv, nconv, one, workl(invsub), & ldq, workl(ihbds), 1, zero, workev, 1) c iconj = 0 do 45 j=1, nconv if (workl(iheigi+j-1) .ne. zero) then c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c %-------------------------------------------% c if (iconj .eq. 0) then workev(j) = slapy2(workev(j), workev(j+1)) workev(j+1) = workev(j) iconj = 1 else iconj = 0 end if end if 45 continue c if (msglvl .gt. 2) then call scopy(ncv, workl(invsub+ncv-1), ldq, & workl(ihbds), 1) call svout(logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the eigenvector matrix for T') if (msglvl .gt. 3) then call smout(logfil, ncv, ncv, workl(invsub), ldq, & ndigit, '_neupd: The eigenvector matrix for T') end if end if c c %---------------------------------------% c | Copy Ritz estimates into workl(ihbds) | c %---------------------------------------% c call scopy(nconv, workev, 1, workl(ihbds), 1) c c %---------------------------------------------------------% c | Compute the QR factorization of the eigenvector matrix | c | associated with leading portion of T in the first NCONV | c | columns of workl(invsub,ldq). | c %---------------------------------------------------------% c call sgeqr2(ncv, nconv , workl(invsub), & ldq, workev, workev(ncv+1), & ierr) c c %----------------------------------------------% c | * Postmultiply Z by Q. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now contains the | c | Ritz vectors associated with the Ritz values | c | in workl(iheigr) and workl(iheigi). | c %----------------------------------------------% c call sorm2r('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , z , & ldz , workd(n+1) , ierr) c call strmm('Right' , 'Upper' , 'No transpose', & 'Non-unit', n , nconv , & one , workl(invsub), ldq , & z , ldz) c end if c else c c %------------------------------------------------------% c | An approximate invariant subspace is not needed. | c | Place the Ritz values computed SNAUPD into DR and DI | c %------------------------------------------------------% c call scopy(nconv, workl(ritzr), 1, dr, 1) call scopy(nconv, workl(ritzi), 1, di, 1) call scopy(nconv, workl(ritzr), 1, workl(iheigr), 1) call scopy(nconv, workl(ritzi), 1, workl(iheigi), 1) call scopy(nconv, workl(bounds), 1, workl(ihbds), 1) end if c c %------------------------------------------------% c | Transform the Ritz values and possibly vectors | c | and corresponding error bounds of OP to those | c | of A*x = lambda*B*x. | c %------------------------------------------------% c if (type .eq. 'REGULR') then c if (rvec) & call sscal(ncv, rnorm, workl(ihbds), 1) c else c c %---------------------------------------% c | A spectral transformation was used. | c | * Determine the Ritz estimates of the | c | Ritz values in the original system. | c %---------------------------------------% c if (type .eq. 'SHIFTI') then c if (rvec) & call sscal(ncv, rnorm, workl(ihbds), 1) c do 50 k=1, ncv temp = slapy2( workl(iheigr+k-1), & workl(iheigi+k-1) ) workl(ihbds+k-1) = abs( workl(ihbds+k-1) ) & / temp / temp 50 continue c else if (type .eq. 'REALPT') then c do 60 k=1, ncv 60 continue c else if (type .eq. 'IMAGPT') then c do 70 k=1, ncv 70 continue c end if c c %-----------------------------------------------------------% c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | For TYPE = 'REALPT' or 'IMAGPT' the user must from | c | Rayleigh quotients or a projection. See remark 3 above.| c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c %-----------------------------------------------------------% c if (type .eq. 'SHIFTI') then c do 80 k=1, ncv temp = slapy2( workl(iheigr+k-1), & workl(iheigi+k-1) ) workl(iheigr+k-1) = workl(iheigr+k-1)/temp/temp & + sigmar workl(iheigi+k-1) = -workl(iheigi+k-1)/temp/temp & + sigmai 80 continue c call scopy(nconv, workl(iheigr), 1, dr, 1) call scopy(nconv, workl(iheigi), 1, di, 1) c else if (type .eq. 'REALPT' .or. type .eq. 'IMAGPT') then c call scopy(nconv, workl(iheigr), 1, dr, 1) call scopy(nconv, workl(iheigi), 1, di, 1) c end if c end if c if (type .eq. 'SHIFTI' .and. msglvl .gt. 1) then call svout(logfil, nconv, dr, ndigit, & '_neupd: Untransformed real part of the Ritz valuess.') call svout (logfil, nconv, di, ndigit, & '_neupd: Untransformed imag part of the Ritz valuess.') call svout(logfil, nconv, workl(ihbds), ndigit, & '_neupd: Ritz estimates of untransformed Ritz values.') else if (type .eq. 'REGULR' .and. msglvl .gt. 1) then call svout(logfil, nconv, dr, ndigit, & '_neupd: Real parts of converged Ritz values.') call svout (logfil, nconv, di, ndigit, & '_neupd: Imag parts of converged Ritz values.') call svout(logfil, nconv, workl(ihbds), ndigit, & '_neupd: Associated Ritz estimates.') end if c c %-------------------------------------------------% c | Eigenvector Purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 2. | c %-------------------------------------------------% c if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then c c %------------------------------------------------% c | Purify the computed Ritz vectors by adding a | c | little bit of the residual vector: | c | T | c | resid(:)*( e s ) / theta | c | NCV | c | where H s = s theta. Remember that when theta | c | has nonzero imaginary part, the corresponding | c | Ritz vector is stored across two columns of Z. | c %------------------------------------------------% c iconj = 0 do 110 j=1, nconv if (workl(iheigi+j-1) .eq. zero) then workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / & workl(iheigr+j-1) else if (iconj .eq. 0) then temp = slapy2( workl(iheigr+j-1), workl(iheigi+j-1) ) workev(j) = ( workl(invsub+(j-1)*ldq+ncv-1) * & workl(iheigr+j-1) + & workl(invsub+j*ldq+ncv-1) * & workl(iheigi+j-1) ) / temp / temp workev(j+1) = ( workl(invsub+j*ldq+ncv-1) * & workl(iheigr+j-1) - & workl(invsub+(j-1)*ldq+ncv-1) * & workl(iheigi+j-1) ) / temp / temp iconj = 1 else iconj = 0 end if 110 continue c c %---------------------------------------% c | Perform a rank one update to Z and | c | purify all the Ritz vectors together. | c %---------------------------------------% c call sger(n, nconv, one, resid, 1, workev, 1, z, ldz) c end if c 9000 continue c return c c %---------------% c | End of SNEUPD | c %---------------% c end arpack-akloeckner-07/SRC/dstqrb.f0000644000175000017500000004062406210503744016577 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dstqrb c c\Description: c Computes all eigenvalues and the last component of the eigenvectors c of a symmetric tridiagonal matrix using the implicit QL or QR method. c c This is mostly a modification of the LAPACK routine dsteqr. c See Remarks. c c\Usage: c call dstqrb c ( N, D, E, Z, WORK, INFO ) c c\Arguments c N Integer. (INPUT) c The number of rows and columns in the matrix. N >= 0. c c D Double precision array, dimension (N). (INPUT/OUTPUT) c On entry, D contains the diagonal elements of the c tridiagonal matrix. c On exit, D contains the eigenvalues, in ascending order. c If an error exit is made, the eigenvalues are correct c for indices 1,2,...,INFO-1, but they are unordered and c may not be the smallest eigenvalues of the matrix. c c E Double precision array, dimension (N-1). (INPUT/OUTPUT) c On entry, E contains the subdiagonal elements of the c tridiagonal matrix in positions 1 through N-1. c On exit, E has been destroyed. c c Z Double precision array, dimension (N). (OUTPUT) c On exit, Z contains the last row of the orthonormal c eigenvector matrix of the symmetric tridiagonal matrix. c If an error exit is made, Z contains the last row of the c eigenvector matrix associated with the stored eigenvalues. c c WORK Double precision array, dimension (max(1,2*N-2)). (WORKSPACE) c Workspace used in accumulating the transformation for c computing the last components of the eigenvectors. c c INFO Integer. (OUTPUT) c = 0: normal return. c < 0: if INFO = -i, the i-th argument had an illegal value. c > 0: if INFO = +i, the i-th eigenvalue has not converged c after a total of 30*N iterations. c c\Remarks c 1. None. c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c daxpy Level 1 BLAS that computes a vector triad. c dcopy Level 1 BLAS that copies one vector to another. c dswap Level 1 BLAS that swaps the contents of two vectors. c lsame LAPACK character comparison routine. c dlae2 LAPACK routine that computes the eigenvalues of a 2-by-2 c symmetric matrix. c dlaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric c matrix. c dlamch LAPACK routine that determines machine constants. c dlanst LAPACK routine that computes the norm of a matrix. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlartg LAPACK Givens rotation construction routine. c dlascl LAPACK routine for careful scaling of a matrix. c dlaset LAPACK matrix initialization routine. c dlasr LAPACK routine that applies an orthogonal transformation to c a matrix. c dlasrt LAPACK sorting routine. c dsteqr LAPACK routine that computes eigenvalues and eigenvectors c of a symmetric tridiagonal matrix. c xerbla LAPACK error handler routine. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c 1. Starting with version 2.5, this routine is a modified version c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, c only commeted out and new lines inserted. c All lines commented out have "c$$$" at the beginning. c Note that the LAPACK version 1.0 subroutine SSTEQR contained c bugs. c c\EndLib c c----------------------------------------------------------------------- c subroutine dstqrb ( n, d, e, z, work, info ) c c %------------------% c | Scalar Arguments | c %------------------% c integer info, n c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) c c .. parameters .. Double precision & zero, one, two, three parameter ( zero = 0.0D+0, one = 1.0D+0, & two = 2.0D+0, three = 3.0D+0 ) integer maxit parameter ( maxit = 30 ) c .. c .. local scalars .. integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend, & lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1, & nm1, nmaxit Double precision & anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, & s, safmax, safmin, ssfmax, ssfmin, tst c .. c .. external functions .. logical lsame Double precision & dlamch, dlanst, dlapy2 external lsame, dlamch, dlanst, dlapy2 c .. c .. external subroutines .. external dlae2, dlaev2, dlartg, dlascl, dlaset, dlasr, & dlasrt, dswap, xerbla c .. c .. intrinsic functions .. intrinsic abs, max, sign, sqrt c .. c .. executable statements .. c c test the input parameters. c info = 0 c c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN c$$$ ICOMPZ = 0 c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN c$$$ ICOMPZ = 1 c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN c$$$ ICOMPZ = 2 c$$$ ELSE c$$$ ICOMPZ = -1 c$$$ END IF c$$$ IF( ICOMPZ.LT.0 ) THEN c$$$ INFO = -1 c$$$ ELSE IF( N.LT.0 ) THEN c$$$ INFO = -2 c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, c$$$ $ N ) ) ) THEN c$$$ INFO = -6 c$$$ END IF c$$$ IF( INFO.NE.0 ) THEN c$$$ CALL XERBLA( 'SSTEQR', -INFO ) c$$$ RETURN c$$$ END IF c c *** New starting with version 2.5 *** c icompz = 2 c ************************************* c c quick return if possible c if( n.eq.0 ) $ return c if( n.eq.1 ) then if( icompz.eq.2 ) z( 1 ) = one return end if c c determine the unit roundoff and over/underflow thresholds. c eps = dlamch( 'e' ) eps2 = eps**2 safmin = dlamch( 's' ) safmax = one / safmin ssfmax = sqrt( safmax ) / three ssfmin = sqrt( safmin ) / eps2 c c compute the eigenvalues and eigenvectors of the tridiagonal c matrix. c c$$ if( icompz.eq.2 ) c$$$ $ call dlaset( 'full', n, n, zero, one, z, ldz ) c c *** New starting with version 2.5 *** c if ( icompz .eq. 2 ) then do 5 j = 1, n-1 z(j) = zero 5 continue z( n ) = one end if c ************************************* c nmaxit = n*maxit jtot = 0 c c determine where the matrix splits and choose ql or qr iteration c for each block, according to whether top or bottom diagonal c element is smaller. c l1 = 1 nm1 = n - 1 c 10 continue if( l1.gt.n ) $ go to 160 if( l1.gt.1 ) $ e( l1-1 ) = zero if( l1.le.nm1 ) then do 20 m = l1, nm1 tst = abs( e( m ) ) if( tst.eq.zero ) $ go to 30 if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+ $ 1 ) ) ) )*eps ) then e( m ) = zero go to 30 end if 20 continue end if m = n c 30 continue l = l1 lsv = l lend = m lendsv = lend l1 = m + 1 if( lend.eq.l ) $ go to 10 c c scale submatrix in rows and columns l to lend c anorm = dlanst( 'i', lend-l+1, d( l ), e( l ) ) iscale = 0 if( anorm.eq.zero ) $ go to 10 if( anorm.gt.ssfmax ) then iscale = 1 call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, $ info ) call dlascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, $ info ) else if( anorm.lt.ssfmin ) then iscale = 2 call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, $ info ) call dlascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, $ info ) end if c c choose between ql and qr iteration c if( abs( d( lend ) ).lt.abs( d( l ) ) ) then lend = lsv l = lendsv end if c if( lend.gt.l ) then c c ql iteration c c look for small subdiagonal element. c 40 continue if( l.ne.lend ) then lendm1 = lend - 1 do 50 m = l, lendm1 tst = abs( e( m ) )**2 if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+ $ safmin )go to 60 50 continue end if c m = lend c 60 continue if( m.lt.lend ) $ e( m ) = zero p = d( l ) if( m.eq.l ) $ go to 80 c c if remaining matrix is 2-by-2, use dlae2 or dlaev2 c to compute its eigensystem. c if( m.eq.l+1 ) then if( icompz.gt.0 ) then call dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s c$$$ call dlasr( 'r', 'v', 'b', n, 2, work( l ), c$$$ $ work( n-1+l ), z( 1, l ), ldz ) c c *** New starting with version 2.5 *** c tst = z(l+1) z(l+1) = c*tst - s*z(l) z(l) = s*tst + c*z(l) c ************************************* else call dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 e( l ) = zero l = l + 2 if( l.le.lend ) $ go to 40 go to 140 end if c if( jtot.eq.nmaxit ) $ go to 140 jtot = jtot + 1 c c form shift. c g = ( d( l+1 )-p ) / ( two*e( l ) ) r = dlapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) c s = one c = one p = zero c c inner loop c mm1 = m - 1 do 70 i = mm1, l, -1 f = s*e( i ) b = c*e( i ) call dlartg( g, f, c, s, r ) if( i.ne.m-1 ) $ e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b p = s*r d( i+1 ) = g + p g = c*r - b c c if eigenvectors are desired, then save rotations. c if( icompz.gt.0 ) then work( i ) = c work( n-1+i ) = -s end if c 70 continue c c if eigenvectors are desired, then apply saved rotations. c if( icompz.gt.0 ) then mm = m - l + 1 c$$$ call dlasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), c$$$ $ z( 1, l ), ldz ) c c *** New starting with version 2.5 *** c call dlasr( 'r', 'v', 'b', 1, mm, work( l ), & work( n-1+l ), z( l ), 1 ) c ************************************* end if c d( l ) = d( l ) - p e( l ) = g go to 40 c c eigenvalue found. c 80 continue d( l ) = p c l = l + 1 if( l.le.lend ) $ go to 40 go to 140 c else c c qr iteration c c look for small superdiagonal element. c 90 continue if( l.ne.lend ) then lendp1 = lend + 1 do 100 m = l, lendp1, -1 tst = abs( e( m-1 ) )**2 if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+ $ safmin )go to 110 100 continue end if c m = lend c 110 continue if( m.gt.lend ) $ e( m-1 ) = zero p = d( l ) if( m.eq.l ) $ go to 130 c c if remaining matrix is 2-by-2, use dlae2 or dlaev2 c to compute its eigensystem. c if( m.eq.l-1 ) then if( icompz.gt.0 ) then call dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) c$$$ work( m ) = c c$$$ work( n-1+m ) = s c$$$ call dlasr( 'r', 'v', 'f', n, 2, work( m ), c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) c c *** New starting with version 2.5 *** c tst = z(l) z(l) = c*tst - s*z(l-1) z(l-1) = s*tst + c*z(l-1) c ************************************* else call dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 e( l-1 ) = zero l = l - 2 if( l.ge.lend ) $ go to 90 go to 140 end if c if( jtot.eq.nmaxit ) $ go to 140 jtot = jtot + 1 c c form shift. c g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) r = dlapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) c s = one c = one p = zero c c inner loop c lm1 = l - 1 do 120 i = m, lm1 f = s*e( i ) b = c*e( i ) call dlartg( g, f, c, s, r ) if( i.ne.m ) $ e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b p = s*r d( i ) = g + p g = c*r - b c c if eigenvectors are desired, then save rotations. c if( icompz.gt.0 ) then work( i ) = c work( n-1+i ) = s end if c 120 continue c c if eigenvectors are desired, then apply saved rotations. c if( icompz.gt.0 ) then mm = l - m + 1 c$$$ call dlasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), c$$$ $ z( 1, m ), ldz ) c c *** New starting with version 2.5 *** c call dlasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), & z( m ), 1 ) c ************************************* end if c d( l ) = d( l ) - p e( lm1 ) = g go to 90 c c eigenvalue found. c 130 continue d( l ) = p c l = l - 1 if( l.ge.lend ) $ go to 90 go to 140 c end if c c undo scaling if necessary c 140 continue if( iscale.eq.1 ) then call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, $ d( lsv ), n, info ) call dlascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ), $ n, info ) else if( iscale.eq.2 ) then call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, $ d( lsv ), n, info ) call dlascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ), $ n, info ) end if c c check for no convergence to an eigenvalue after a total c of n*maxit iterations. c if( jtot.lt.nmaxit ) $ go to 10 do 150 i = 1, n - 1 if( e( i ).ne.zero ) $ info = info + 1 150 continue go to 190 c c order eigenvalues and eigenvectors. c 160 continue if( icompz.eq.0 ) then c c use quick sort c call dlasrt( 'i', n, d, info ) c else c c use selection sort to minimize swaps of eigenvectors c do 180 ii = 2, n i = ii - 1 k = i p = d( i ) do 170 j = ii, n if( d( j ).lt.p ) then k = j p = d( j ) end if 170 continue if( k.ne.i ) then d( k ) = d( i ) d( i ) = p c$$$ call dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) c *** New starting with version 2.5 *** c p = z(k) z(k) = z(i) z(i) = p c ************************************* end if 180 continue end if c 190 continue return c c %---------------% c | End of dstqrb | c %---------------% c end arpack-akloeckner-07/SRC/sgetv0.f0000644000175000017500000003146610670622032016511 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: sgetv0 c c\Description: c Generate a random initial residual vector for the Arnoldi process. c Force the residual vector to be in the range of the operator OP. c c\Usage: c call sgetv0 c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, c IPNTR, WORKD, IERR ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to sgetv0. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B in the (generalized) c eigenvalue problem A*x = lambda*B*x. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c ITRY Integer. (INPUT) c ITRY counts the number of times that sgetv0 is called. c It should be set to 1 on the initial call to sgetv0. c c INITV Logical variable. (INPUT) c .TRUE. => the initial residual vector is given in RESID. c .FALSE. => generate a random initial residual vector. c c N Integer. (INPUT) c Dimension of the problem. c c J Integer. (INPUT) c Index of the residual vector to be generated, with respect to c the Arnoldi process. J > 1 in case of a "restart". c c V Real N by J array. (INPUT) c The first J-1 columns of V contain the current Arnoldi basis c if this is a "restart". c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c RESID Real array of length N. (INPUT/OUTPUT) c Initial residual vector to be generated. If RESID is c provided, force RESID into the range of the operator OP. c c RNORM Real scalar. (OUTPUT) c B-norm of the generated residual. c c IPNTR Integer array of length 3. (OUTPUT) c c WORKD Real work array of length 2*N. (REVERSE COMMUNICATION). c On exit, WORK(1:N) = B*RESID to be used in SSAITR. c c IERR Integer. (OUTPUT) c = 0: Normal exit. c = -1: Cannot generate a nontrivial restarted residual vector c in the range of the operator OP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c arscnd ARPACK utility routine for timing. c svout ARPACK utility routine for vector output. c slarnv LAPACK routine for generating a random vector. c sgemv Level 2 BLAS routine for matrix vector multiplication. c scopy Level 1 BLAS that copies one vector to another. c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: getv0.F SID: 2.7 DATE OF SID: 04/07/99 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine sgetv0 & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, & ipntr, workd, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 logical initv integer ido, ierr, itry, j, ldv, n Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Real & resid(n), v(ldv,j), workd(2*n) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical first, inits, orth integer idist, iseed(4), iter, msglvl, jj Real & rnorm0 save first, iseed, inits, iter, msglvl, orth, rnorm0 c c %----------------------% c | External Subroutines | c %----------------------% c external slarnv, svout, scopy, sgemv, arscnd c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2 external sdot, snrm2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, sqrt c c %-----------------% c | Data Statements | c %-----------------% c data inits /.true./ c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-----------------------------------% c | Initialize the seed of the LAPACK | c | random number generator | c %-----------------------------------% c if (inits) then iseed(1) = 1 iseed(2) = 3 iseed(3) = 5 iseed(4) = 7 inits = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mgetv0 c ierr = 0 iter = 0 first = .FALSE. orth = .FALSE. c c %-----------------------------------------------------% c | Possibly generate a random starting vector in RESID | c | Use a LAPACK random number generator used by the | c | matrix generation routines. | c | idist = 1: uniform (0,1) distribution; | c | idist = 2: uniform (-1,1) distribution; | c | idist = 3: normal (0,1) distribution; | c %-----------------------------------------------------% c if (.not.initv) then idist = 2 call slarnv (idist, iseed, n, resid) end if c c %----------------------------------------------------------% c | Force the starting vector into the range of OP to handle | c | the generalized problem when B is possibly (singular). | c %----------------------------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nopx = nopx + 1 ipntr(1) = 1 ipntr(2) = n + 1 call scopy (n, resid, 1, workd, 1) ido = -1 go to 9000 end if end if c c %-----------------------------------------% c | Back from computing OP*(initial-vector) | c %-----------------------------------------% c if (first) go to 20 c c %-----------------------------------------------% c | Back from computing B*(orthogonalized-vector) | c %-----------------------------------------------% c if (orth) go to 40 c if (bmat .eq. 'G') then call arscnd (t3) tmvopx = tmvopx + (t3 - t2) end if c c %------------------------------------------------------% c | Starting vector is now in the range of OP; r = OP*r; | c | Compute B-norm of starting vector. | c %------------------------------------------------------% c call arscnd (t2) first = .TRUE. if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, workd(n+1), 1, resid, 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd, 1) end if c 20 continue c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c first = .FALSE. if (bmat .eq. 'G') then rnorm0 = sdot (n, resid, 1, workd, 1) rnorm0 = sqrt(abs(rnorm0)) else if (bmat .eq. 'I') then rnorm0 = snrm2(n, resid, 1) end if rnorm = rnorm0 c c %---------------------------------------------% c | Exit if this is the very first Arnoldi step | c %---------------------------------------------% c if (j .eq. 1) go to 50 c c %---------------------------------------------------------------- c | Otherwise need to B-orthogonalize the starting vector against | c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | c | This is the case where an invariant subspace is encountered | c | in the middle of the Arnoldi factorization. | c | | c | s = V^{T}*B*r; r = r - V*s; | c | | c | Stopping criteria used for iter. ref. is discussed in | c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | c %---------------------------------------------------------------% c orth = .TRUE. 30 continue c call sgemv ('T', n, j-1, one, v, ldv, workd, 1, & zero, workd(n+1), 1) call sgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, & one, resid, 1) c c %----------------------------------------------------------% c | Compute the B-norm of the orthogonalized starting vector | c %----------------------------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd, 1) end if c 40 continue c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if c c %--------------------------------------% c | Check for further orthogonalization. | c %--------------------------------------% c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm0, ndigit, & '_getv0: re-orthonalization ; rnorm0 is') call svout (logfil, 1, rnorm, ndigit, & '_getv0: re-orthonalization ; rnorm is') end if c if (rnorm .gt. 0.717*rnorm0) go to 50 c iter = iter + 1 if (iter .le. 5) then c c %-----------------------------------% c | Perform iterative refinement step | c %-----------------------------------% c rnorm0 = rnorm go to 30 else c c %------------------------------------% c | Iterative refinement step "failed" | c %------------------------------------% c do 45 jj = 1, n resid(jj) = zero 45 continue rnorm = zero ierr = -1 end if c 50 continue c if (msglvl .gt. 0) then call svout (logfil, 1, rnorm, ndigit, & '_getv0: B-norm of initial / restarted starting vector') end if if (msglvl .gt. 3) then call svout (logfil, n, resid, ndigit, & '_getv0: initial / restarted starting vector') end if ido = 99 c call arscnd (t1) tgetv0 = tgetv0 + (t1 - t0) c 9000 continue return c c %---------------% c | End of sgetv0 | c %---------------% c end arpack-akloeckner-07/SRC/slaqrb.f0000644000175000017500000004364406210503373016567 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: slaqrb c c\Description: c Compute the eigenvalues and the Schur decomposition of an upper c Hessenberg submatrix in rows and columns ILO to IHI. Only the c last component of the Schur vectors are computed. c c This is mostly a modification of the LAPACK routine slahqr. c c\Usage: c call slaqrb c ( WANTT, N, ILO, IHI, H, LDH, WR, WI, Z, INFO ) c c\Arguments c WANTT Logical variable. (INPUT) c = .TRUE. : the full Schur form T is required; c = .FALSE.: only eigenvalues are required. c c N Integer. (INPUT) c The order of the matrix H. N >= 0. c c ILO Integer. (INPUT) c IHI Integer. (INPUT) c It is assumed that H is already upper quasi-triangular in c rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless c ILO = 1). SLAQRB works primarily with the Hessenberg c submatrix in rows and columns ILO to IHI, but applies c transformations to all of H if WANTT is .TRUE.. c 1 <= ILO <= max(1,IHI); IHI <= N. c c H Real array, dimension (LDH,N). (INPUT/OUTPUT) c On entry, the upper Hessenberg matrix H. c On exit, if WANTT is .TRUE., H is upper quasi-triangular in c rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in c standard form. If WANTT is .FALSE., the contents of H are c unspecified on exit. c c LDH Integer. (INPUT) c The leading dimension of the array H. LDH >= max(1,N). c c WR Real array, dimension (N). (OUTPUT) c WI Real array, dimension (N). (OUTPUT) c The real and imaginary parts, respectively, of the computed c eigenvalues ILO to IHI are stored in the corresponding c elements of WR and WI. If two eigenvalues are computed as a c complex conjugate pair, they are stored in consecutive c elements of WR and WI, say the i-th and (i+1)th, with c WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the c eigenvalues are stored in the same order as on the diagonal c of the Schur form returned in H, with WR(i) = H(i,i), and, if c H(i:i+1,i:i+1) is a 2-by-2 diagonal block, c WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). c c Z Real array, dimension (N). (OUTPUT) c On exit Z contains the last components of the Schur vectors. c c INFO Integer. (OUPUT) c = 0: successful exit c > 0: SLAQRB failed to compute all the eigenvalues ILO to IHI c in a total of 30*(IHI-ILO+1) iterations; if INFO = i, c elements i+1:ihi of WR and WI contain those eigenvalues c which have been successfully computed. c c\Remarks c 1. None. c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c slabad LAPACK routine that computes machine constants. c slamch LAPACK routine that determines machine constants. c slanhs LAPACK routine that computes various norms of a matrix. c slanv2 LAPACK routine that computes the Schur factorization of c 2 by 2 nonsymmetric matrix in standard form. c slarfg LAPACK Householder reflection construction routine. c scopy Level 1 BLAS that copies one vector to another. c srot Level 1 BLAS that applies a rotation to a 2 by 2 matrix. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c Modified from the LAPACK routine slahqr so that only the c last component of the Schur vectors are computed. c c\SCCS Information: @(#) c FILE: laqrb.F SID: 2.2 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine slaqrb ( wantt, n, ilo, ihi, h, ldh, wr, wi, & z, info ) c c %------------------% c | Scalar Arguments | c %------------------% c logical wantt integer ihi, ilo, info, ldh, n c c %-----------------% c | Array Arguments | c %-----------------% c Real & h( ldh, * ), wi( * ), wr( * ), z( * ) c c %------------% c | Parameters | c %------------% c Real & zero, one, dat1, dat2 parameter (zero = 0.0E+0, one = 1.0E+0, dat1 = 7.5E-1, & dat2 = -4.375E-1) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, i1, i2, itn, its, j, k, l, m, nh, nr Real & cs, h00, h10, h11, h12, h21, h22, h33, h33s, & h43h34, h44, h44s, ovfl, s, smlnum, sn, sum, & t1, t2, t3, tst1, ulp, unfl, v1, v2, v3 Real & v( 3 ), work( 1 ) c c %--------------------% c | External Functions | c %--------------------% c Real & slamch, slanhs external slamch, slanhs c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, slabad, slanv2, slarfg, srot c c %-----------------------% c | Executable Statements | c %-----------------------% c info = 0 c c %--------------------------% c | Quick return if possible | c %--------------------------% c if( n.eq.0 ) & return if( ilo.eq.ihi ) then wr( ilo ) = h( ilo, ilo ) wi( ilo ) = zero return end if c c %---------------------------------------------% c | Initialize the vector of last components of | c | the Schur vectors for accumulation. | c %---------------------------------------------% c do 5 j = 1, n-1 z(j) = zero 5 continue z(n) = one c nh = ihi - ilo + 1 c c %-------------------------------------------------------------% c | Set machine-dependent constants for the stopping criterion. | c | If norm(H) <= sqrt(OVFL), overflow should not occur. | c %-------------------------------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = one / unfl call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( nh / ulp ) c c %---------------------------------------------------------------% c | I1 and I2 are the indices of the first row and last column | c | of H to which transformations must be applied. If eigenvalues | c | only are computed, I1 and I2 are set inside the main loop. | c | Zero out H(J+2,J) = ZERO for J=1:N if WANTT = .TRUE. | c | else H(J+2,J) for J=ILO:IHI-ILO-1 if WANTT = .FALSE. | c %---------------------------------------------------------------% c if( wantt ) then i1 = 1 i2 = n do 8 i=1,i2-2 h(i1+i+1,i) = zero 8 continue else do 9 i=1, ihi-ilo-1 h(ilo+i+1,ilo+i-1) = zero 9 continue end if c c %---------------------------------------------------% c | ITN is the total number of QR iterations allowed. | c %---------------------------------------------------% c itn = 30*nh c c ------------------------------------------------------------------ c The main loop begins here. I is the loop index and decreases from c IHI to ILO in steps of 1 or 2. Each iteration of the loop works c with the active submatrix in rows and columns L to I. c Eigenvalues I+1 to IHI have already converged. Either L = ILO or c H(L,L-1) is negligible so that the matrix splits. c ------------------------------------------------------------------ c i = ihi 10 continue l = ilo if( i.lt.ilo ) & go to 150 c %--------------------------------------------------------------% c | Perform QR iterations on rows and columns ILO to I until a | c | submatrix of order 1 or 2 splits off at the bottom because a | c | subdiagonal element has become negligible. | c %--------------------------------------------------------------% do 130 its = 0, itn c c %----------------------------------------------% c | Look for a single small subdiagonal element. | c %----------------------------------------------% c do 20 k = i, l + 1, -1 tst1 = abs( h( k-1, k-1 ) ) + abs( h( k, k ) ) if( tst1.eq.zero ) & tst1 = slanhs( '1', i-l+1, h( l, l ), ldh, work ) if( abs( h( k, k-1 ) ).le.max( ulp*tst1, smlnum ) ) & go to 30 20 continue 30 continue l = k if( l.gt.ilo ) then c c %------------------------% c | H(L,L-1) is negligible | c %------------------------% c h( l, l-1 ) = zero end if c c %-------------------------------------------------------------% c | Exit from loop if a submatrix of order 1 or 2 has split off | c %-------------------------------------------------------------% c if( l.ge.i-1 ) & go to 140 c c %---------------------------------------------------------% c | Now the active submatrix is in rows and columns L to I. | c | If eigenvalues only are being computed, only the active | c | submatrix need be transformed. | c %---------------------------------------------------------% c if( .not.wantt ) then i1 = l i2 = i end if c if( its.eq.10 .or. its.eq.20 ) then c c %-------------------% c | Exceptional shift | c %-------------------% c s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) h44 = dat1*s h33 = h44 h43h34 = dat2*s*s c else c c %-----------------------------------------% c | Prepare to use Wilkinson's double shift | c %-----------------------------------------% c h44 = h( i, i ) h33 = h( i-1, i-1 ) h43h34 = h( i, i-1 )*h( i-1, i ) end if c c %-----------------------------------------------------% c | Look for two consecutive small subdiagonal elements | c %-----------------------------------------------------% c do 40 m = i - 2, l, -1 c c %---------------------------------------------------------% c | Determine the effect of starting the double-shift QR | c | iteration at row M, and see if this would make H(M,M-1) | c | negligible. | c %---------------------------------------------------------% c h11 = h( m, m ) h22 = h( m+1, m+1 ) h21 = h( m+1, m ) h12 = h( m, m+1 ) h44s = h44 - h11 h33s = h33 - h11 v1 = ( h33s*h44s-h43h34 ) / h21 + h12 v2 = h22 - h11 - h33s - h44s v3 = h( m+2, m+1 ) s = abs( v1 ) + abs( v2 ) + abs( v3 ) v1 = v1 / s v2 = v2 / s v3 = v3 / s v( 1 ) = v1 v( 2 ) = v2 v( 3 ) = v3 if( m.eq.l ) & go to 50 h00 = h( m-1, m-1 ) h10 = h( m, m-1 ) tst1 = abs( v1 )*( abs( h00 )+abs( h11 )+abs( h22 ) ) if( abs( h10 )*( abs( v2 )+abs( v3 ) ).le.ulp*tst1 ) & go to 50 40 continue 50 continue c c %----------------------% c | Double-shift QR step | c %----------------------% c do 120 k = m, i - 1 c c ------------------------------------------------------------ c The first iteration of this loop determines a reflection G c from the vector V and applies it from left and right to H, c thus creating a nonzero bulge below the subdiagonal. c c Each subsequent iteration determines a reflection G to c restore the Hessenberg form in the (K-1)th column, and thus c chases the bulge one step toward the bottom of the active c submatrix. NR is the order of G. c ------------------------------------------------------------ c nr = min( 3, i-k+1 ) if( k.gt.m ) & call scopy( nr, h( k, k-1 ), 1, v, 1 ) call slarfg( nr, v( 1 ), v( 2 ), 1, t1 ) if( k.gt.m ) then h( k, k-1 ) = v( 1 ) h( k+1, k-1 ) = zero if( k.lt.i-1 ) & h( k+2, k-1 ) = zero else if( m.gt.l ) then h( k, k-1 ) = -h( k, k-1 ) end if v2 = v( 2 ) t2 = t1*v2 if( nr.eq.3 ) then v3 = v( 3 ) t3 = t1*v3 c c %------------------------------------------------% c | Apply G from the left to transform the rows of | c | the matrix in columns K to I2. | c %------------------------------------------------% c do 60 j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 h( k+2, j ) = h( k+2, j ) - sum*t3 60 continue c c %----------------------------------------------------% c | Apply G from the right to transform the columns of | c | the matrix in rows I1 to min(K+3,I). | c %----------------------------------------------------% c do 70 j = i1, min( k+3, i ) sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 h( j, k+2 ) = h( j, k+2 ) - sum*t3 70 continue c c %----------------------------------% c | Accumulate transformations for Z | c %----------------------------------% c sum = z( k ) + v2*z( k+1 ) + v3*z( k+2 ) z( k ) = z( k ) - sum*t1 z( k+1 ) = z( k+1 ) - sum*t2 z( k+2 ) = z( k+2 ) - sum*t3 else if( nr.eq.2 ) then c c %------------------------------------------------% c | Apply G from the left to transform the rows of | c | the matrix in columns K to I2. | c %------------------------------------------------% c do 90 j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 90 continue c c %----------------------------------------------------% c | Apply G from the right to transform the columns of | c | the matrix in rows I1 to min(K+3,I). | c %----------------------------------------------------% c do 100 j = i1, i sum = h( j, k ) + v2*h( j, k+1 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 100 continue c c %----------------------------------% c | Accumulate transformations for Z | c %----------------------------------% c sum = z( k ) + v2*z( k+1 ) z( k ) = z( k ) - sum*t1 z( k+1 ) = z( k+1 ) - sum*t2 end if 120 continue 130 continue c c %-------------------------------------------------------% c | Failure to converge in remaining number of iterations | c %-------------------------------------------------------% c info = i return 140 continue if( l.eq.i ) then c c %------------------------------------------------------% c | H(I,I-1) is negligible: one eigenvalue has converged | c %------------------------------------------------------% c wr( i ) = h( i, i ) wi( i ) = zero else if( l.eq.i-1 ) then c c %--------------------------------------------------------% c | H(I-1,I-2) is negligible; | c | a pair of eigenvalues have converged. | c | | c | Transform the 2-by-2 submatrix to standard Schur form, | c | and compute and store the eigenvalues. | c %--------------------------------------------------------% c call slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ), & h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ), & cs, sn ) if( wantt ) then c c %-----------------------------------------------------% c | Apply the transformation to the rest of H and to Z, | c | as required. | c %-----------------------------------------------------% c if( i2.gt.i ) & call srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh, & cs, sn ) call srot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) sum = cs*z( i-1 ) + sn*z( i ) z( i ) = cs*z( i ) - sn*z( i-1 ) z( i-1 ) = sum end if end if c c %---------------------------------------------------------% c | Decrement number of remaining iterations, and return to | c | start of the main loop with new value of I. | c %---------------------------------------------------------% c itn = itn - its i = l - 1 go to 10 150 continue return c c %---------------% c | End of slaqrb | c %---------------% c end arpack-akloeckner-07/SRC/snaitr.f0000644000175000017500000007346710670622032016610 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: snaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step nonsymmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in snaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call snaitr c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and do not need to be c recompute in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. See snaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current size of V and H. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c NB Integer. (INPUT) c Blocksize to be used in the recurrence. c Only work for NB = 1 right now. The goal is to have a c program that implement both the block and non-block method. c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Real scalar. (INPUT/OUTPUT) c B-norm of the starting residual on input. c B-norm of the updated residual r_{k+p} on output. c c V Real N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (K+NP) by (K+NP) array. (INPUT/OUTPUT) c H is used to store the generated upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On input, WORKD(1:N) = B*RESID and is used to save some c computation at the first step. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of the spanning invariant subspace of OP found. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c sgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c smout ARPACK utility routine that prints matrices c svout ARPACK utility routine that prints vectors. c slabad LAPACK routine that computes machine constants. c slamch LAPACK routine that determines machine constants. c slascl LAPACK routine for careful scaling of a matrix. c slanhs LAPACK routine that computes various norms of a matrix. c sgemv Level 2 BLAS routine for matrix vector multiplication. c saxpy Level 1 BLAS that computes a vector triad. c sscal Level 1 BLAS that scales a vector. c scopy Level 1 BLAS that copies one vector to another . c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: naitr.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c ( At present tol is zero ) c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in snaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c H(:,j) = w_{j}; c H(j,j-1) = rnorm c rnorm = || r_(j) || c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine snaitr & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, nb, np Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Real & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, & jj Real & betaj, ovfl, temp1, rnorm1, smlnum, tst1, ulp, unfl, & wnorm save first, orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, & betaj, rnorm1, smlnum, ulp, unfl, wnorm c c %-----------------------% c | Local Array Arguments | c %-----------------------% c Real & xtemp(2) c c %----------------------% c | External Subroutines | c %----------------------% c external saxpy, scopy, sscal, sgemv, sgetv0, slabad, & svout, smout, ivout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2, slanhs, slamch external sdot, snrm2, slanhs, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs, sqrt c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------% c | Set machine-dependent constants for the | c | the splitting and deflation criterion. | c | If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine slahqr | c %-----------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = one / unfl call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mnaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. j = k + 1 ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. when .... | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | sgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %-----------------------------% c | Else this is the first step | c %-----------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% 1000 continue c if (msglvl .gt. 1) then call ivout (logfil, 1, j, ndigit, & '_naitr: generating Arnoldi vector number') call svout (logfil, 1, rnorm, ndigit, & '_naitr: B-norm of the current residual is') end if c c %---------------------------------------------------% c | STEP 1: Check if the B norm of j-th residual | c | vector is zero. Equivalent to determing whether | c | an exact j-step Arnoldi factorization is present. | c %---------------------------------------------------% c betaj = rnorm if (rnorm .gt. zero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: ****** RESTART AT STEP ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c betaj = zero nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call arscnd (t1) tnaitr = tnaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call scopy (n, resid, 1, v(1,j), 1) if (rnorm .ge. unfl) then temp1 = one / rnorm call sscal (n, temp1, v(1,j), 1) call sscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine SLASCL | c %-----------------------------------------% c call slascl ('General', i, i, rnorm, one, n, 1, & v(1,j), n, infol) call slascl ('General', i, i, rnorm, one, n, 1, & workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call arscnd (t2) call scopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | c | if step3 = .true. | c %----------------------------------% c call arscnd (t3) tmvopx = tmvopx + (t3 - t2) step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call scopy (n, workd(irj), 1, resid, 1) c c %---------------------------------------% c | STEP 4: Finish extending the Arnoldi | c | factorization to length j. | c %---------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 60 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | c | if step4 = .true. | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c if (bmat .eq. 'G') then wnorm = sdot (n, resid, 1, workd(ipj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'I') then wnorm = snrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, h(1,j), 1) c c %--------------------------------------% c | Orthogonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call sgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c if (j .gt. 1) h(j,j-1) = betaj c call arscnd (t4) c orth1 = .true. c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd(ipj), 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c | The following test determines whether the sine of the | c | angle between OP*x and the computed residual is less | c | than or equal to 0.717. | c %-----------------------------------------------------------% c if (rnorm .gt. 0.717*wnorm) go to 100 iter = 0 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then xtemp(1) = wnorm xtemp(2) = rnorm call svout (logfil, 2, xtemp, ndigit, & '_naitr: re-orthonalization; wnorm and rnorm are') call svout (logfil, j, h(1,j), ndigit, & '_naitr: j-th column of H') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %---------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) | c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | c %---------------------------------------------% c call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) call saxpy (j, one, workd(irj), 1, h(1,j), 1) c orth2 = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then rnorm1 = sdot (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt(abs(rnorm1)) else if (bmat .eq. 'I') then rnorm1 = snrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then xtemp(1) = rnorm xtemp(2) = rnorm1 call svout (logfil, 2, xtemp, ndigit, & '_naitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if (rnorm1 .gt. 0.717*rnorm) then c c %---------------------------------------% c | No need for further refinement. | c | The cosine of the angle between the | c | corrected residual vector and the old | c | residual vector is greater than 0.717 | c | In other words the corrected residual | c | and the old residual vector share an | c | angle of less than arcCOS(0.717) | c %---------------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = zero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call arscnd (t5) titref = titref + (t5 - t4) c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call arscnd (t1) tnaitr = tnaitr + (t1 - t0) ido = 99 do 110 i = max(1,k), k+np-1 c c %--------------------------------------------% c | Check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine slahqr | c %--------------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = slanhs( '1', k+np, h, ldh, workd(n+1) ) if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue c if (msglvl .gt. 2) then call smout (logfil, k+np, k+np, h, ldh, ndigit, & '_naitr: Final upper Hessenberg matrix H of order K+NP') end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of snaitr | c %---------------% c end arpack-akloeckner-07/SRC/snapps.f0000644000175000017500000005551510670622032016606 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: snapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP implicit shifts resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix which is the product of rotations c and reflections resulting from the NP bulge chage sweeps. c The updated Arnoldi factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call snapps c ( N, KEV, NP, SHIFTR, SHIFTI, V, LDV, H, LDH, RESID, Q, LDQ, c WORKL, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. size of matrix A. c c KEV Integer. (INPUT/OUTPUT) c KEV+NP is the size of the input matrix H. c KEV is the size of the updated matrix HNEW. KEV is only c updated on ouput when fewer than NP shifts are applied in c order to keep the conjugate pair together. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFTR, Real array of length NP. (INPUT) c SHIFTI Real and imaginary part of the shifts to be applied. c Upon, entry to snapps, the shifts must be sorted so that the c conjugate pairs are in consecutive locations. c c V Real N by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, V contains the current KEV+NP Arnoldi vectors. c On OUTPUT, V contains the updated KEV Arnoldi vectors c in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, H contains the current KEV+NP by KEV+NP upper c Hessenber matrix of the Arnoldi factorization. c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg c matrix in the KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT, RESID contains the the residual vector r_{k+p}. c On OUTPUT, RESID is the update residual vector rnew_{k} c in the first KEV locations. c c Q Real KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations and reflections c during the bulge chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Real work array of length (KEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c WORKD Real work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c smout ARPACK utility routine that prints matrices. c svout ARPACK utility routine that prints vectors. c slabad LAPACK routine that computes machine constants. c slacpy LAPACK matrix copy routine. c slamch LAPACK routine that determines machine constants. c slanhs LAPACK routine that computes various norms of a matrix. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slarf LAPACK routine that applies Householder reflection to c a matrix. c slarfg LAPACK Householder reflection construction routine. c slartg LAPACK Givens rotation construction routine. c slaset LAPACK matrix initialization routine. c sgemv Level 2 BLAS routine for matrix vector multiplication. c saxpy Level 1 BLAS that computes a vector triad. c scopy Level 1 BLAS that copies one vector to another . c sscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: napps.F SID: 2.4 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the sublocks of c the Hessenberg matrix H and not just to the submatrix that it c comes from. Deflation as in LAPACK routine slahqr (QR algorithm c for upper Hessenberg matrices ) is used. c The subdiagonals of H are enforced to be non-negative. c c\EndLib c c----------------------------------------------------------------------- c subroutine snapps & ( n, kev, np, shiftr, shifti, v, ldv, h, ldh, resid, q, ldq, & workl, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Real & h(ldh,kev+np), resid(n), shifti(np), shiftr(np), & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, iend, ir, istart, j, jj, kplusp, msglvl, nr logical cconj, first Real & c, f, g, h11, h12, h21, h22, h32, ovfl, r, s, sigmai, & sigmar, smlnum, ulp, unfl, u(3), t, tau, tst1 save first, ovfl, smlnum, ulp, unfl c c %----------------------% c | External Subroutines | c %----------------------% c external saxpy, scopy, sscal, slacpy, slarfg, slarf, & slaset, slabad, arscnd, slartg c c %--------------------% c | External Functions | c %--------------------% c Real & slamch, slanhs, slapy2 external slamch, slanhs, slapy2 c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs, max, min c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------------% c | Set machine-dependent constants for the | c | stopping criterion. If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine slahqr | c %-----------------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = one / unfl call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mnapps kplusp = kev + np c c %--------------------------------------------% c | Initialize Q to the identity to accumulate | c | the rotations and reflections | c %--------------------------------------------% c call slaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------% c | Chase the bulge with the application of each | c | implicit shift. Each shift is applied to the | c | whole matrix including each block. | c %----------------------------------------------% c cconj = .false. do 110 jj = 1, np sigmar = shiftr(jj) sigmai = shifti(jj) c if (msglvl .gt. 2 ) then call ivout (logfil, 1, jj, ndigit, & '_napps: shift number.') call svout (logfil, 1, sigmar, ndigit, & '_napps: The real part of the shift ') call svout (logfil, 1, sigmai, ndigit, & '_napps: The imaginary part of the shift ') end if c c %-------------------------------------------------% c | The following set of conditionals is necessary | c | in order that complex conjugate pairs of shifts | c | are applied together or not at all. | c %-------------------------------------------------% c if ( cconj ) then c c %-----------------------------------------% c | cconj = .true. means the previous shift | c | had non-zero imaginary part. | c %-----------------------------------------% c cconj = .false. go to 110 else if ( jj .lt. np .and. abs( sigmai ) .gt. zero ) then c c %------------------------------------% c | Start of a complex conjugate pair. | c %------------------------------------% c cconj = .true. else if ( jj .eq. np .and. abs( sigmai ) .gt. zero ) then c c %----------------------------------------------% c | The last shift has a nonzero imaginary part. | c | Don't apply it; thus the order of the | c | compressed H is order KEV+1 since only np-1 | c | were applied. | c %----------------------------------------------% c kev = kev + 1 go to 110 end if istart = 1 20 continue c c %--------------------------------------------------% c | if sigmai = 0 then | c | Apply the jj-th shift ... | c | else | c | Apply the jj-th and (jj+1)-th together ... | c | (Note that jj < np at this point in the code) | c | end | c | to the current block of H. The next do loop | c | determines the current block ; | c %--------------------------------------------------% c do 30 i = istart, kplusp-1 c c %----------------------------------------% c | Check for splitting and deflation. Use | c | a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine slahqr | c %----------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = slanhs( '1', kplusp-jj+1, h, ldh, workl ) if( abs( h( i+1,i ) ).le.max( ulp*tst1, smlnum ) ) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_napps: matrix splitting at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_napps: matrix splitting with shift number.') call svout (logfil, 1, h(i+1,i), ndigit, & '_napps: off diagonal element.') end if iend = i h(i+1,i) = zero go to 40 end if 30 continue iend = kplusp 40 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, istart, ndigit, & '_napps: Start of current block ') call ivout (logfil, 1, iend, ndigit, & '_napps: End of current block ') end if c c %------------------------------------------------% c | No reason to apply a shift to block of order 1 | c %------------------------------------------------% c if ( istart .eq. iend ) go to 100 c c %------------------------------------------------------% c | If istart + 1 = iend then no reason to apply a | c | complex conjugate pair of shifts on a 2 by 2 matrix. | c %------------------------------------------------------% c if ( istart + 1 .eq. iend .and. abs( sigmai ) .gt. zero ) & go to 100 c h11 = h(istart,istart) h21 = h(istart+1,istart) if ( abs( sigmai ) .le. zero ) then c c %---------------------------------------------% c | Real-valued shift ==> apply single shift QR | c %---------------------------------------------% c f = h11 - sigmar g = h21 c do 80 i = istart, iend-1 c c %-----------------------------------------------------% c | Contruct the plane rotation G to zero out the bulge | c %-----------------------------------------------------% c call slartg (f, g, c, s, r) if (i .gt. istart) then c c %-------------------------------------------% c | The following ensures that h(1:iend-1,1), | c | the first iend-2 off diagonal of elements | c | H, remain non negative. | c %-------------------------------------------% c if (r .lt. zero) then r = -r c = -c s = -s end if h(i,i-1) = r h(i+1,i-1) = zero end if c c %---------------------------------------------% c | Apply rotation to the left of H; H <- G'*H | c %---------------------------------------------% c do 50 j = i, kplusp t = c*h(i,j) + s*h(i+1,j) h(i+1,j) = -s*h(i,j) + c*h(i+1,j) h(i,j) = t 50 continue c c %---------------------------------------------% c | Apply rotation to the right of H; H <- H*G | c %---------------------------------------------% c do 60 j = 1, min(i+2,iend) t = c*h(j,i) + s*h(j,i+1) h(j,i+1) = -s*h(j,i) + c*h(j,i+1) h(j,i) = t 60 continue c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 70 j = 1, min( i+jj, kplusp ) t = c*q(j,i) + s*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = t 70 continue c c %---------------------------% c | Prepare for next rotation | c %---------------------------% c if (i .lt. iend-1) then f = h(i+1,i) g = h(i+2,i) end if 80 continue c c %-----------------------------------% c | Finished applying the real shift. | c %-----------------------------------% c else c c %----------------------------------------------------% c | Complex conjugate shifts ==> apply double shift QR | c %----------------------------------------------------% c h12 = h(istart,istart+1) h22 = h(istart+1,istart+1) h32 = h(istart+2,istart+1) c c %---------------------------------------------------------% c | Compute 1st column of (H - shift*I)*(H - conj(shift)*I) | c %---------------------------------------------------------% c s = 2.0*sigmar t = slapy2 ( sigmar, sigmai ) u(1) = ( h11 * (h11 - s) + t * t ) / h21 + h12 u(2) = h11 + h22 - s u(3) = h32 c do 90 i = istart, iend-1 c nr = min ( 3, iend-i+1 ) c c %-----------------------------------------------------% c | Construct Householder reflector G to zero out u(1). | c | G is of the form I - tau*( 1 u )' * ( 1 u' ). | c %-----------------------------------------------------% c call slarfg ( nr, u(1), u(2), 1, tau ) c if (i .gt. istart) then h(i,i-1) = u(1) h(i+1,i-1) = zero if (i .lt. iend-1) h(i+2,i-1) = zero end if u(1) = one c c %--------------------------------------% c | Apply the reflector to the left of H | c %--------------------------------------% c call slarf ('Left', nr, kplusp-i+1, u, 1, tau, & h(i,i), ldh, workl) c c %---------------------------------------% c | Apply the reflector to the right of H | c %---------------------------------------% c ir = min ( i+3, iend ) call slarf ('Right', ir, nr, u, 1, tau, & h(1,i), ldh, workl) c c %-----------------------------------------------------% c | Accumulate the reflector in the matrix Q; Q <- Q*G | c %-----------------------------------------------------% c call slarf ('Right', kplusp, nr, u, 1, tau, & q(1,i), ldq, workl) c c %----------------------------% c | Prepare for next reflector | c %----------------------------% c if (i .lt. iend-1) then u(1) = h(i+1,i) u(2) = h(i+2,i) if (i .lt. iend-2) u(3) = h(i+3,i) end if c 90 continue c c %--------------------------------------------% c | Finished applying a complex pair of shifts | c | to the current block | c %--------------------------------------------% c end if c 100 continue c c %---------------------------------------------------------% c | Apply the same shift to the next block if there is any. | c %---------------------------------------------------------% c istart = iend + 1 if (iend .lt. kplusp) go to 20 c c %---------------------------------------------% c | Loop back to the top to get the next shift. | c %---------------------------------------------% c 110 continue c c %--------------------------------------------------% c | Perform a similarity transformation that makes | c | sure that H will have non negative sub diagonals | c %--------------------------------------------------% c do 120 j=1,kev if ( h(j+1,j) .lt. zero ) then call sscal( kplusp-j+1, -one, h(j+1,j), ldh ) call sscal( min(j+2, kplusp), -one, h(1,j+1), 1 ) call sscal( min(j+np+1,kplusp), -one, q(1,j+1), 1 ) end if 120 continue c do 130 i = 1, kev c c %--------------------------------------------% c | Final check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine slahqr | c %--------------------------------------------% c tst1 = abs( h( i, i ) ) + abs( h( i+1, i+1 ) ) if( tst1.eq.zero ) & tst1 = slanhs( '1', kev, h, ldh, workl ) if( h( i+1,i ) .le. max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 130 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is needed in the residual update since we | c | cannot GUARANTEE that the corresponding entry | c | of H would be zero as in exact arithmetic. | c %-------------------------------------------------% c if (h(kev+1,kev) .gt. zero) & call sgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, & workd(n+1), 1) c c %----------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage of the upper Hessenberg structure of Q. | c %----------------------------------------------------------% c do 140 i = 1, kev call sgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call scopy (n, workd, 1, v(1,kplusp-i+1), 1) 140 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call slacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) c c %--------------------------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | c %--------------------------------------------------------------% c if (h(kev+1,kev) .gt. zero) & call scopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kplusp}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call sscal (n, q(kplusp,kev), resid, 1) if (h(kev+1,kev) .gt. zero) & call saxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call svout (logfil, 1, q(kplusp,kev), ndigit, & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') call svout (logfil, 1, h(kev+1,kev), ndigit, & '_napps: betak = e_{kev+1}^T*H*e_{kev}') call ivout (logfil, 1, kev, ndigit, & '_napps: Order of the final Hessenberg matrix ') if (msglvl .gt. 2) then call smout (logfil, kev, kev, h, ldh, ndigit, & '_napps: updated Hessenberg matrix H for next iteration') end if c end if c 9000 continue call arscnd (t1) tnapps = tnapps + (t1 - t0) c return c c %---------------% c | End of snapps | c %---------------% c end arpack-akloeckner-07/SRC/snaup2.f0000644000175000017500000007514510670622032016513 0ustar andreasandreasc\BeginDoc c c\Name: snaup2 c c\Description: c Intermediate level interface called by snaupd. c c\Usage: c call snaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZR, RITZI, BOUNDS, c Q, LDQ, WORKL, IPNTR, WORKD, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in snaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in snaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV for two reasons. The first, is c to keep complex conjugate pairs of "wanted" Ritz values c together. The second, is that a leading block of the current c upper Hessenberg matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Real N by (NEV+NP) array. (INPUT/OUTPUT) c The Arnoldi basis vectors are returned in the first NEV c columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (NEV+NP) by (NEV+NP) array. (OUTPUT) c H is used to store the generated upper Hessenberg matrix c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZR, Real arrays of length NEV+NP. (OUTPUT) c RITZI RITZR(1:NEV) (resp. RITZI(1:NEV)) contains the real (resp. c imaginary) part of the computed Ritz values of OP. c c BOUNDS Real array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to c the computed Ritz values. c c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Real work array of length at least c (NEV+NP)**2 + 3*(NEV+NP). (INPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in shifts calculation, shifts c application and convergence checking. c c On exit, the last 3*(NEV+NP) locations of WORKL contain c the Ritz values (real,imaginary) and associated Ritz c estimates of the current Hessenberg matrix. They are c listed in the same order as returned from sneigh. c c If ISHIFT .EQ. O and IDO .EQ. 3, the first 2*NP locations c of WORKL are used in reverse communication to hold the user c supplied shifts. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (WORKSPACE) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in DNAUPD. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. c NP returns the number of converged Ritz values. c = 2: No shifts could be applied. c = -8: Error return from LAPACK eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Arnoldi factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c sgetv0 ARPACK initial vector generation routine. c snaitr ARPACK Arnoldi factorization routine. c snapps ARPACK application of implicit shifts routine. c snconv ARPACK convergence of Ritz values routine. c sneigh ARPACK compute Ritz values and error bounds routine. c sngets ARPACK reorder Ritz values and error bounds routine. c ssortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c smout ARPACK utility routine that prints matrices c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c scopy Level 1 BLAS that copies one vector to another . c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c sswap Level 1 BLAS that swaps two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naup2.F SID: 2.8 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine snaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ipntr, workd, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, & n, nev, np Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(13) Real & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), resid(n), & ritzi(nev+np), ritzr(nev+np), v(ldv,nev+np), & workd(3*n), workl( (nev+np)*(nev+np+3) ) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c character wprime*2 logical cnorm , getv0, initv, update, ushift integer ierr , iter , j , kplusp, msglvl, nconv, & nevbef, nev0 , np0 , nptemp, numcnv Real & rnorm , temp , eps23 save cnorm , getv0, initv, update, ushift, & rnorm , iter , eps23, kplusp, msglvl, nconv , & nevbef, nev0 , np0 , numcnv c c %-----------------------% c | Local array arguments | c %-----------------------% c integer kp(4) c c %----------------------% c | External Subroutines | c %----------------------% c external scopy , sgetv0, snaitr, snconv, sneigh, & sngets, snapps, svout , ivout , arscnd c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2, slapy2, slamch external sdot, snrm2, slapy2, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min, max, abs, sqrt c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c call arscnd (t0) c msglvl = mnaup2 c c %-------------------------------------% c | Get the machine dependent constant. | c %-------------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0) c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvlues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev + np nconv = 0 iter = 0 c c %---------------------------------------% c | Set flags for computing the first NEV | c | steps of the Arnoldi factorization. | c %---------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. zero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1100 end if getv0 = .false. ido = 0 end if c c %-----------------------------------% c | Back from reverse communication : | c | continue with update step | c %-----------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Arnoldi factorization | c %----------------------------------------------------------% c call snaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N ARNOLDI I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Arnoldi | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_naup2: **** Start of major iteration number ****') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c | Adjust NP since NEV might have been updated by last call | c | to the shift application routine snapps. | c %-----------------------------------------------------------% c np = kplusp - nev c if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_naup2: The length of the current Arnoldi factorization') call ivout (logfil, 1, np, ndigit, & '_naup2: Extend the Arnoldi factorization by') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c %-----------------------------------------------------------% c ido = 0 20 continue update = .true. c call snaitr (ido , bmat, n , nev, np , mode , resid, & rnorm, v , ldv, h , ldh, ipntr, workd, & info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call svout (logfil, 1, rnorm, ndigit, & '_naup2: Corresponding B-norm of the residual') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current upper Hessenberg matrix. | c %--------------------------------------------------------% c call sneigh (rnorm, kplusp, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %----------------------------------------------------% c | Make a copy of eigenvalues and corresponding error | c | bounds obtained from sneigh. | c %----------------------------------------------------% c call scopy(kplusp, ritzr, 1, workl(kplusp**2+1), 1) call scopy(kplusp, ritzi, 1, workl(kplusp**2+kplusp+1), 1) call scopy(kplusp, bounds, 1, workl(kplusp**2+2*kplusp+1), 1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | error bounds are in the last NEV loc. of RITZR, | c | RITZI and BOUNDS respectively. The variables NEV | c | and NP may be updated if the NEV-th wanted Ritz | c | value has a non zero imaginary part. In this case | c | NEV is increased by one and NP decreased by one. | c | NOTE: The last two arguments of sngets are no | c | longer used as of version 2.1. | c %---------------------------------------------------% c nev = nev0 np = np0 numcnv = nev call sngets (ishift, which, nev, np, ritzr, ritzi, & bounds, workl, workl(np+1)) if (nev .eq. nev0+1) numcnv = nev0+1 c c %-------------------% c | Convergence test. | c %-------------------% c call scopy (nev, bounds(np+1), 1, workl(2*np+1), 1) call snconv (nev, ritzr(np+1), ritzi(np+1), workl(2*np+1), & tol, nconv) c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = numcnv kp(4) = nconv call ivout (logfil, 4, kp, ndigit, & '_naup2: NEV, NP, NUMCNV, NCONV are') call svout (logfil, kplusp, ritzr, ndigit, & '_naup2: Real part of the eigenvalues of H') call svout (logfil, kplusp, ritzi, ndigit, & '_naup2: Imaginary part of the eigenvalues of H') call svout (logfil, kplusp, bounds, ndigit, & '_naup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. numcnv) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c if (msglvl .gt. 4) then call svout(logfil, kplusp, workl(kplusp**2+1), ndigit, & '_naup2: Real part of the eig computed by _neigh:') call svout(logfil, kplusp, workl(kplusp**2+kplusp+1), & ndigit, & '_naup2: Imag part of the eig computed by _neigh:') call svout(logfil, kplusp, workl(kplusp**2+kplusp*2+1), & ndigit, & '_naup2: Ritz eistmates computed by _neigh:') end if c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP | c %------------------------------------------------% c c %------------------------------------------% c | Use h( 3,1 ) as storage to communicate | c | rnorm to _neupd if needed | c %------------------------------------------% h(3,1) = rnorm c c %----------------------------------------------% c | To be consistent with sngets, we first do a | c | pre-processing sort in order to keep complex | c | conjugate pairs together. This is similar | c | to the pre-processing sort used in sngets | c | except that the sort is done in the opposite | c | order. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SR' if (which .eq. 'SM') wprime = 'LR' if (which .eq. 'LR') wprime = 'SM' if (which .eq. 'SR') wprime = 'LM' if (which .eq. 'LI') wprime = 'SM' if (which .eq. 'SI') wprime = 'LM' c call ssortc (wprime, .true., kplusp, ritzr, ritzi, bounds) c c %----------------------------------------------% c | Now sort Ritz values so that converged Ritz | c | values appear within the first NEV locations | c | of ritzr, ritzi and bounds, and the most | c | desired one appears at the front. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LR') wprime = 'SR' if (which .eq. 'SR') wprime = 'LR' if (which .eq. 'LI') wprime = 'SI' if (which .eq. 'SI') wprime = 'LI' c call ssortc(wprime, .true., kplusp, ritzr, ritzi, bounds) c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23,magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, numcnv temp = max(eps23,slapy2(ritzr(j), & ritzi(j))) bounds(j) = bounds(j)/temp 35 continue c c %----------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | esitmates. This will push all the converged ones | c | towards the front of ritzr, ritzi, bounds | c | (in the case when NCONV < NEV.) | c %----------------------------------------------------% c wprime = 'LR' call ssortc(wprime, .true., numcnv, bounds, ritzr, ritzi) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, numcnv temp = max(eps23, slapy2(ritzr(j), & ritzi(j))) bounds(j) = bounds(j)*temp 40 continue c c %------------------------------------------------% c | Sort the converged Ritz values again so that | c | the "threshold" value appears at the front of | c | ritzr, ritzi and bound. | c %------------------------------------------------% c call ssortc(which, .true., nconv, ritzr, ritzi, bounds) c if (msglvl .gt. 1) then call svout (logfil, kplusp, ritzr, ndigit, & '_naup2: Sorted real part of the eigenvalues') call svout (logfil, kplusp, ritzi, ndigit, & '_naup2: Sorted imaginary part of the eigenvalues') call svout (logfil, kplusp, bounds, ndigit, & '_naup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. numcnv) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. numcnv) info = 2 c np = nconv go to 1100 c else if ( (nconv .lt. numcnv) .and. (ishift .eq. 1) ) then c c %-------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the size | c | of NEV. | c %-------------------------------------------------% c nevbef = nev nev = nev + min(nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 3) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call sngets (ishift, which, nev, np, ritzr, ritzi, & bounds, workl, workl(np+1)) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_naup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_naup2: NEV and NP are') call svout (logfil, nev, ritzr(np+1), ndigit, & '_naup2: "wanted" Ritz values -- real part') call svout (logfil, nev, ritzi(np+1), ndigit, & '_naup2: "wanted" Ritz values -- imag part') call svout (logfil, nev, bounds(np+1), ndigit, & '_naup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-------------------------------------------------------% c | User specified shifts: reverse comminucation to | c | compute the shifts. They are returned in the first | c | 2*NP locations of WORKL. | c %-------------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if c 50 continue c c %------------------------------------% c | Back from reverse communication; | c | User specified shifts are returned | c | in WORKL(1:2*NP) | c %------------------------------------% c ushift = .false. c if ( ishift .eq. 0 ) then c c %----------------------------------% c | Move the NP shifts from WORKL to | c | RITZR, RITZI to free up WORKL | c | for non-exact shift case. | c %----------------------------------% c call scopy (np, workl, 1, ritzr, 1) call scopy (np, workl(np+1), 1, ritzi, 1) end if c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_naup2: The number of shifts to apply ') call svout (logfil, np, ritzr, ndigit, & '_naup2: Real part of the shifts') call svout (logfil, np, ritzi, ndigit, & '_naup2: Imaginary part of the shifts') if ( ishift .eq. 1 ) & call svout (logfil, np, bounds, ndigit, & '_naup2: Ritz estimates of the shifts') end if c c %---------------------------------------------------------% c | Apply the NP implicit shifts by QR bulge chasing. | c | Each shift is applied to the whole upper Hessenberg | c | matrix H. | c | The first 2*N locations of WORKD are used as workspace. | c %---------------------------------------------------------% c call snapps (n, nev, np, ritzr, ritzi, v, ldv, & h, ldh, resid, q, ldq, workl, workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to snaitr. | c %---------------------------------------------% c cnorm = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if cnorm = .false. c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm, ndigit, & '_naup2: B-norm of residual for compressed factorization') call smout (logfil, nev, nev, h, ldh, ndigit, & '_naup2: Compressed upper Hessenberg matrix H') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = numcnv c 1200 continue ido = 99 c c %------------% c | Error Exit | c %------------% c call arscnd (t1) tnaup2 = t1 - t0 c 9000 continue c c %---------------% c | End of snaup2 | c %---------------% c return end arpack-akloeckner-07/SRC/snaupd.f0000644000175000017500000007161710670622032016575 0ustar andreasandreasc\BeginDoc c c\Name: snaupd c c\Description: c Reverse communication interface for the Implicitly Restarted Arnoldi c iteration. This subroutine computes approximations to a few eigenpairs c of a linear operator "OP" with respect to a semi-inner product defined by c a symmetric positive semi-definite real matrix B. B may be the identity c matrix. NOTE: If the linear operator "OP" is real and symmetric c with respect to the real positive semi-definite symmetric matrix B, c i.e. B*OP = (OP`)*B, then subroutine ssaupd should be used instead. c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c snaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x. c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: A*x = lambda*M*x, M symmetric semi-definite c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*x = amu*x, then c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. c Note: If sigma is real, i.e. imaginary part of sigma is zero; c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M c amu == 1/(lambda-sigma). c c Mode 4: A*x = lambda*M*x, M symmetric semi-definite c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*x = amu*x, then c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. c c Both mode 3 and 4 give the same enhancement to eigenvalues close to c the (complex) shift sigma. However, as lambda goes to infinity, c the operator OP in mode 4 dampens the eigenvalues more strongly than c does OP defined in mode 3. c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call snaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to snaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c snaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3 and 4, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute the IPARAM(8) real and imaginary parts c of the shifts where INPTR(14) is the pointer c into WORKL for placing the shifts. See Remark c 5 below. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c NEV Integer. (INPUT/OUTPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. c c TOL Real scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = SLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine SLAMCH). c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 2 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. c NOTE: 2 <= NCV-NEV in order that complex conjugate pairs of Ritz c values are kept together. (See remark 4 below) c c V Real array N by NCV. (OUTPUT) c Contains the final set of Arnoldi basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are provided by the user via c reverse communication. The real and imaginary c parts of the NCV eigenvalues of the Hessenberg c matrix H are returned in the part of the WORKL c array corresponding to RITZR and RITZI. See remark c 5 below. c ISHIFT = 1: exact shifts with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of approximate Schur c vectors associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced. c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4; See under \Description of snaupd for the c four modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), snaupd returns NP, the number c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark c 5 below. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 14. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by NCV upper Hessenberg matrix c H in WORKL. c IPNTR(6): pointer to the real part of the ritz value array c RITZR in WORKL. c IPNTR(7): pointer to the imaginary part of the ritz value array c RITZI in WORKL. c IPNTR(8): pointer to the Ritz estimates in array WORKL associated c with the Ritz values located in RITZR and RITZI in WORKL. c c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. c c Note: IPNTR(9:13) is only referenced by sneupd. See Remark 2 below. c c IPNTR(9): pointer to the real part of the NCV RITZ values of the c original system. c IPNTR(10): pointer to the imaginary part of the NCV RITZ values of c the original system. c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper quasi-triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c sneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration. Upon termination c WORKD(1:N) contains B*RESID(1:N). If an invariant subspace c associated with the converged Ritz values is desired, see remark c 2 below, subroutine sneupd uses this output. c See Data Distribution Note below. c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 6*NCV. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -4: The maximum number of Arnoldi update iteration c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation; c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. c = -12: IPARAM(1) must be equal to 0 or 1. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current Arnoldi c factorization. c c\Remarks c 1. The computed Ritz values are approximate eigenvalues of OP. The c selection of WHICH should be made with this in mind when c Mode = 3 and 4. After convergence, approximate eigenvalues of the c original problem may be obtained with the ARPACK subroutine sneupd. c c 2. If a basis for the invariant subspace corresponding to the converged Ritz c values is needed, the user must call sneupd immediately following c completion of snaupd. This is new starting with release 2 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requrement is that NCV > NEV + 2. c However, it is recommended that NCV .ge. 2*NEV+1. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c See Chapter 8 of Reference 2 for further information. c c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) real and imaginary parts of the shifts in locations c real part imaginary part c ----------------------- -------------- c 1 WORKL(IPNTR(14)) WORKL(IPNTR(14)+NP) c 2 WORKL(IPNTR(14)+1) WORKL(IPNTR(14)+NP+1) c . . c . . c . . c NP WORKL(IPNTR(14)+NP-1) WORKL(IPNTR(14)+2*NP-1). c c Only complex conjugate pairs of shifts may be applied and the pairs c must be placed in consecutive locations. The real part of the c eigenvalues of the current upper Hessenberg matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1) and the imaginary part c in WORKL(IPNTR(7)) through WORKL(IPNTR(7)+NCV-1). They are ordered c according to the order defined by WHICH. The complex conjugate c pairs are kept together and the associated Ritz estimates are located in c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c Real resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c decompose d1(n), d2(n,ncv) c align resid(i) with d1(i) c align v(i,j) with d2(i,j) c align workd(i) with d1(i) range (1:n) c align workd(i) with d1(i-n) range (n+1:2*n) c align workd(i) with d1(i-2*n) range (2*n+1:3*n) c distribute d1(block), d2(block,:) c replicated workl(lworkl) c c Cray MPP syntax: c =============== c Real resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) c shared resid(block), v(block,:), workd(block,:) c replicated workl(lworkl) c c CM2/CM5 syntax: c ============== c c----------------------------------------------------------------------- c c include 'ex-nonsym.doc' c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c snaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version '1.1' c c\SCCS Information: @(#) c FILE: naupd.F SID: 2.10 DATE OF SID: 08/23/02 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine snaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) Real & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritzi, ritzr, j save bounds, ih, iq, ishift, iupd, iw, ldh, ldq, & levec, mode, msglvl, mxiter, nb, nev0, next, & np, ritzi, ritzr c c %----------------------% c | External Subroutines | c %----------------------% c external snaup2, svout, ivout, arscnd, sstatn c c %--------------------% c | External Functions | c %--------------------% c Real & slamch external slamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call sstatn call arscnd (t0) msglvl = mnaupd c c %----------------% c | Error checking | c %----------------% c ierr = 0 ishift = iparam(1) c levec = iparam(2) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev+1 .or. ncv .gt. n) then ierr = -3 else if (mxiter .le. 0) then ierr = 4 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 6*ncv) then ierr = -7 else if (mode .lt. 1 .or. mode .gt. 4) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 else if (ishift .lt. 0 .or. ishift .gt. 1) then ierr = -12 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. zero) tol = slamch('EpsMach') c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, 3*ncv**2 + 6*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+2*ncv) := real and imaginary | c | parts of ritz values | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := error bounds | c | workl(ncv*ncv+3*ncv+1:2*ncv*ncv+3*ncv) := rotation matrix Q | c | workl(2*ncv*ncv+3*ncv+1:3*ncv*ncv+6*ncv) := workspace | c | The final workspace is needed by subroutine sneigh called | c | by snaup2. Subroutine sneigh calls LAPACK routines for | c | calculating eigenvalues and the last row of the eigenvector | c | matrix. | c %-------------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritzr = ih + ldh*ncv ritzi = ritzr + ncv bounds = ritzi + ncv iq = bounds + ncv iw = iq + ldq*ncv next = iw + ncv**2 + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritzr ipntr(7) = ritzi ipntr(8) = bounds ipntr(14) = iw c end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Arnoldi Iteration. | c %-------------------------------------------------------% c call snaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritzr), & workl(ritzi), workl(bounds), workl(iq), ldq, workl(iw), & ipntr, workd, info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP or shifts. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within snaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_naupd: Number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_naupd: Number of wanted "converged" Ritz values') call svout (logfil, np, workl(ritzr), ndigit, & '_naupd: Real part of the final Ritz values') call svout (logfil, np, workl(ritzi), ndigit, & '_naupd: Imaginary part of the final Ritz values') call svout (logfil, np, workl(bounds), ndigit, & '_naupd: Associated Ritz estimates') end if c call arscnd (t1) tnaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tnaupd, tnaup2, tnaitr, titref, & tgetv0, tneigh, tngets, tnapps, tnconv, trvec 1000 format (//, & 5x, '=============================================',/ & 5x, '= Nonsymmetric implicit Arnoldi update code =',/ & 5x, '= Version Number: ', ' 2.4', 21x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ & 5x, '=============================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '=============================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in naup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6,/ & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) end if c 9000 continue c return c c %---------------% c | End of snaupd | c %---------------% c end arpack-akloeckner-07/SRC/snconv.f0000644000175000017500000000764110670622032016605 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: snconv c c\Description: c Convergence testing for the nonsymmetric Arnoldi eigenvalue routine. c c\Usage: c call snconv c ( N, RITZR, RITZI, BOUNDS, TOL, NCONV ) c c\Arguments c N Integer. (INPUT) c Number of Ritz values to check for convergence. c c RITZR, Real arrays of length N. (INPUT) c RITZI Real and imaginary parts of the Ritz values to be checked c for convergence. c BOUNDS Real array of length N. (INPUT) c Ritz estimates for the Ritz values in RITZR and RITZI. c c TOL Real scalar. (INPUT) c Desired backward error for a Ritz value to be considered c "converged". c c NCONV Integer scalar. (OUTPUT) c Number of "converged" Ritz values. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c arscnd ARPACK utility routine for timing. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: nconv.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. xxxx c c\EndLib c c----------------------------------------------------------------------- c subroutine snconv (n, ritzr, ritzi, bounds, tol, nconv) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer n, nconv Real & tol c c %-----------------% c | Array Arguments | c %-----------------% Real & ritzr(n), ritzi(n), bounds(n) c c %---------------% c | Local Scalars | c %---------------% c integer i Real & temp, eps23 c c %--------------------% c | External Functions | c %--------------------% c Real & slapy2, slamch external slapy2, slamch c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------------------% c | Convergence test: unlike in the symmetric code, I am not | c | using things like refined error bounds and gap condition | c | because I don't know the exact equivalent concept. | c | | c | Instead the i-th Ritz value is considered "converged" when: | c | | c | bounds(i) .le. ( TOL * | ritz | ) | c | | c | for some appropriate choice of norm. | c %-------------------------------------------------------------% c call arscnd (t0) c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0) c nconv = 0 do 20 i = 1, n temp = max( eps23, slapy2( ritzr(i), ritzi(i) ) ) if (bounds(i) .le. tol*temp) nconv = nconv + 1 20 continue c call arscnd (t1) tnconv = tnconv + (t1 - t0) c return c c %---------------% c | End of snconv | c %---------------% c end arpack-akloeckner-07/SRC/sneigh.f0000644000175000017500000002403510670622032016550 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: sneigh c c\Description: c Compute the eigenvalues of the current upper Hessenberg matrix c and the corresponding Ritz estimates given the current residual norm. c c\Usage: c call sneigh c ( RNORM, N, H, LDH, RITZR, RITZI, BOUNDS, Q, LDQ, WORKL, IERR ) c c\Arguments c RNORM Real scalar. (INPUT) c Residual norm corresponding to the current upper Hessenberg c matrix H. c c N Integer. (INPUT) c Size of the matrix H. c c H Real N by N array. (INPUT) c H contains the current upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZR, Real arrays of length N. (OUTPUT) c RITZI On output, RITZR(1:N) (resp. RITZI(1:N)) contains the real c (respectively imaginary) parts of the eigenvalues of H. c c BOUNDS Real array of length N. (OUTPUT) c On output, BOUNDS contains the Ritz estimates associated with c the eigenvalues RITZR and RITZI. This is equal to RNORM c times the last components of the eigenvectors corresponding c to the eigenvalues in RITZR and RITZI. c c Q Real N by N array. (WORKSPACE) c Workspace needed to store the eigenvectors of H. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Real work array of length N**2 + 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. This is needed to keep the full Schur form c of H and also in the calculation of the eigenvectors of H. c c IERR Integer. (OUTPUT) c Error exit flag from slaqrb or strevc. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c slaqrb ARPACK routine to compute the real Schur form of an c upper Hessenberg matrix and last row of the Schur vectors. c arscnd ARPACK utility routine for timing. c smout ARPACK utility routine that prints matrices c svout ARPACK utility routine that prints vectors. c slacpy LAPACK matrix copy routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c strevc LAPACK routine to compute the eigenvectors of a matrix c in upper quasi-triangular form c sgemv Level 2 BLAS routine for matrix vector multiplication. c scopy Level 1 BLAS that copies one vector to another . c snrm2 Level 1 BLAS that computes the norm of a vector. c sscal Level 1 BLAS that scales a vector. c c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: neigh.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine sneigh (rnorm, n, h, ldh, ritzr, ritzi, bounds, & q, ldq, workl, ierr) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, n, ldh, ldq Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Real & bounds(n), h(ldh,n), q(ldq,n), ritzi(n), ritzr(n), & workl(n*(n+3)) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical select(1) integer i, iconj, msglvl Real & temp, vl(1) c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, slacpy, slaqrb, strevc, svout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Real & slapy2, snrm2 external slapy2, snrm2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mneigh c if (msglvl .gt. 2) then call smout (logfil, n, n, h, ldh, ndigit, & '_neigh: Entering upper Hessenberg matrix H ') end if c c %-----------------------------------------------------------% c | 1. Compute the eigenvalues, the last components of the | c | corresponding Schur vectors and the full Schur form T | c | of the current upper Hessenberg matrix H. | c | slaqrb returns the full Schur form of H in WORKL(1:N**2) | c | and the last components of the Schur vectors in BOUNDS. | c %-----------------------------------------------------------% c call slacpy ('All', n, n, h, ldh, workl, n) call slaqrb (.true., n, 1, n, workl, n, ritzr, ritzi, bounds, & ierr) if (ierr .ne. 0) go to 9000 c if (msglvl .gt. 1) then call svout (logfil, n, bounds, ndigit, & '_neigh: last row of the Schur matrix for H') end if c c %-----------------------------------------------------------% c | 2. Compute the eigenvectors of the full Schur form T and | c | apply the last components of the Schur vectors to get | c | the last components of the corresponding eigenvectors. | c | Remember that if the i-th and (i+1)-st eigenvalues are | c | complex conjugate pairs, then the real & imaginary part | c | of the eigenvector components are split across adjacent | c | columns of Q. | c %-----------------------------------------------------------% c call strevc ('R', 'A', select, n, workl, n, vl, n, q, ldq, & n, n, workl(n*n+1), ierr) c if (ierr .ne. 0) go to 9000 c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | euclidean norms are all one. LAPACK subroutine | c | strevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; here the magnitude of a complex | c | number (x,y) is taken to be |x| + |y|. | c %------------------------------------------------% c iconj = 0 do 10 i=1, n if ( abs( ritzi(i) ) .le. zero ) then c c %----------------------% c | Real eigenvalue case | c %----------------------% c temp = snrm2( n, q(1,i), 1 ) call sscal ( n, one / temp, q(1,i), 1 ) else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we further normalize by the | c | square root of two. | c %-------------------------------------------% c if (iconj .eq. 0) then temp = slapy2( snrm2( n, q(1,i), 1 ), & snrm2( n, q(1,i+1), 1 ) ) call sscal ( n, one / temp, q(1,i), 1 ) call sscal ( n, one / temp, q(1,i+1), 1 ) iconj = 1 else iconj = 0 end if end if 10 continue c call sgemv ('T', n, n, one, q, ldq, bounds, 1, zero, workl, 1) c if (msglvl .gt. 1) then call svout (logfil, n, workl, ndigit, & '_neigh: Last row of the eigenvector matrix for H') end if c c %----------------------------% c | Compute the Ritz estimates | c %----------------------------% c iconj = 0 do 20 i = 1, n if ( abs( ritzi(i) ) .le. zero ) then c c %----------------------% c | Real eigenvalue case | c %----------------------% c bounds(i) = rnorm * abs( workl(i) ) else c c %-------------------------------------------% c | Complex conjugate pair case. Note that | c | since the real and imaginary part of | c | the eigenvector are stored in consecutive | c | columns, we need to take the magnitude | c | of the last components of the two vectors | c %-------------------------------------------% c if (iconj .eq. 0) then bounds(i) = rnorm * slapy2( workl(i), workl(i+1) ) bounds(i+1) = bounds(i) iconj = 1 else iconj = 0 end if end if 20 continue c if (msglvl .gt. 2) then call svout (logfil, n, ritzr, ndigit, & '_neigh: Real part of the eigenvalues of H') call svout (logfil, n, ritzi, ndigit, & '_neigh: Imaginary part of the eigenvalues of H') call svout (logfil, n, bounds, ndigit, & '_neigh: Ritz estimates for the eigenvalues of H') end if c call arscnd (t1) tneigh = tneigh + (t1 - t0) c 9000 continue return c c %---------------% c | End of sneigh | c %---------------% c end arpack-akloeckner-07/SRC/sngets.f0000644000175000017500000001745410670622032016605 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: sngets c c\Description: c Given the eigenvalues of the upper Hessenberg matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: call this even in the case of user specified shifts in order c to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call sngets c ( ISHIFT, WHICH, KEV, NP, RITZR, RITZI, BOUNDS, SHIFTR, SHIFTI ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> want the KEV eigenvalues of largest magnitude. c 'SM' -> want the KEV eigenvalues of smallest magnitude. c 'LR' -> want the KEV eigenvalues of largest real part. c 'SR' -> want the KEV eigenvalues of smallest real part. c 'LI' -> want the KEV eigenvalues of largest imaginary part. c 'SI' -> want the KEV eigenvalues of smallest imaginary part. c c KEV Integer. (INPUT/OUTPUT) c INPUT: KEV+NP is the size of the matrix H. c OUTPUT: Possibly increases KEV by one to keep complex conjugate c pairs together. c c NP Integer. (INPUT/OUTPUT) c Number of implicit shifts to be computed. c OUTPUT: Possibly decreases NP by one to keep complex conjugate c pairs together. c c RITZR, Real array of length KEV+NP. (INPUT/OUTPUT) c RITZI On INPUT, RITZR and RITZI contain the real and imaginary c parts of the eigenvalues of H. c On OUTPUT, RITZR and RITZI are sorted so that the unwanted c eigenvalues are in the first NP locations and the wanted c portion is in the last KEV locations. When exact shifts are c selected, the unwanted part corresponds to the shifts to c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues c are further sorted so that the ones with largest Ritz values c are first. c c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c SHIFTR, SHIFTI *** USE deprecated as of version 2.1. *** c c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c ssortc ARPACK sorting routine. c scopy Level 1 BLAS that copies one vector to another . c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c c\SCCS Information: @(#) c FILE: ngets.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. xxxx c c\EndLib c c----------------------------------------------------------------------- c subroutine sngets ( ishift, which, kev, np, ritzr, ritzi, bounds, & shiftr, shifti ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Real & bounds(kev+np), ritzr(kev+np), ritzi(kev+np), & shiftr(1), shifti(1) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0, zero = 0.0) c c %---------------% c | Local Scalars | c %---------------% c integer msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, ssortc, arscnd c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mngets c c %----------------------------------------------------% c | LM, SM, LR, SR, LI, SI case. | c | Sort the eigenvalues of H into the desired order | c | and apply the resulting order to BOUNDS. | c | The eigenvalues are sorted so that the wanted part | c | are always in the last KEV locations. | c | We first do a pre-processing sort in order to keep | c | complex conjugate pairs together | c %----------------------------------------------------% c if (which .eq. 'LM') then call ssortc ('LR', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SM') then call ssortc ('SR', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'LR') then call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SR') then call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'LI') then call ssortc ('LM', .true., kev+np, ritzr, ritzi, bounds) else if (which .eq. 'SI') then call ssortc ('SM', .true., kev+np, ritzr, ritzi, bounds) end if c call ssortc (which, .true., kev+np, ritzr, ritzi, bounds) c c %-------------------------------------------------------% c | Increase KEV by one if the ( ritzr(np),ritzi(np) ) | c | = ( ritzr(np+1),-ritzi(np+1) ) and ritz(np) .ne. zero | c | Accordingly decrease NP by one. In other words keep | c | complex conjugate pairs together. | c %-------------------------------------------------------% c if ( ( ritzr(np+1) - ritzr(np) ) .eq. zero & .and. ( ritzi(np+1) + ritzi(np) ) .eq. zero ) then np = np - 1 kev = kev + 1 end if c if ( ishift .eq. 1 ) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first | c | This will tend to minimize the effects of the | c | forward instability of the iteration when they shifts | c | are applied in subroutine snapps. | c | Be careful and use 'SR' since we want to sort BOUNDS! | c %-------------------------------------------------------% c call ssortc ( 'SR', .true., np, bounds, ritzr, ritzi ) end if c call arscnd (t1) tngets = tngets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') call ivout (logfil, 1, np, ndigit, '_ngets: NP is') call svout (logfil, kev+np, ritzr, ndigit, & '_ngets: Eigenvalues of current H matrix -- real part') call svout (logfil, kev+np, ritzi, ndigit, & '_ngets: Eigenvalues of current H matrix -- imag part') call svout (logfil, kev+np, bounds, ndigit, & '_ngets: Ritz estimates of the current KEV+NP Ritz values') end if c return c c %---------------% c | End of sngets | c %---------------% c end arpack-akloeckner-07/SRC/ssaitr.f0000644000175000017500000007372710670622032016614 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step symmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in ssaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call ssaitr c ( IDO, BMAT, N, K, NP, MODE, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and does not need to be c recomputed in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of matrix B that defines the c semi-inner product for the operator OP. See ssaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current order of H and the number of columns of V. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c MODE Integer. (INPUT) c Signifies which form for "OP". If MODE=2 then c a reduction in the number of B matrix vector multiplies c is possible since the B-norm of OP*x is equivalent to c the inv(B)-norm of A*x. c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Real scalar. (INPUT/OUTPUT) c On INPUT the B-norm of r_{k}. c On OUTPUT the B-norm of the updated residual r_{k+p}. c c V Real N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (K+NP) by 2 array. (INPUT/OUTPUT) c H is used to store the generated symmetric tridiagonal matrix c with the subdiagonal in the first column starting at H(2,1) c and the main diagonal in the second column. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On INPUT, WORKD(1:N) = B*RESID where RESID is associated c with the K step Arnoldi factorization. Used to save some c computation at the first step. c On OUTPUT, WORKD(1:N) = B*RESID where RESID is associated c with the K+NP step Arnoldi factorization. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of an invariant subspace of OP is found that is c less than K + NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c sgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c smout ARPACK utility routine that prints matrices. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c slascl LAPACK routine for careful scaling of a matrix. c sgemv Level 2 BLAS routine for matrix vector multiplication. c saxpy Level 1 BLAS that computes a vector triad. c sscal Level 1 BLAS that scales a vector. c scopy Level 1 BLAS that copies one vector to another . c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: saitr.F SID: 2.6 DATE OF SID: 8/28/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in ssaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c alphaj <- j-th component of w_{j} c rnorm = || r_{j} || c betaj+1 = rnorm c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine ssaitr & (ido, bmat, n, k, np, mode, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, mode, np Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Real & h(ldh,2), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer i, ierr, ipj, irj, ivj, iter, itry, j, msglvl, & infol, jj Real & rnorm1, wnorm, safmin, temp1 save orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, & rnorm1, safmin, wnorm c c %-----------------------% c | Local Array Arguments | c %-----------------------% c Real & xtemp(2) c c %----------------------% c | External Subroutines | c %----------------------% c external saxpy, scopy, sscal, sgemv, sgetv0, svout, smout, & slascl, ivout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2, slamch external sdot, snrm2, slamch c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then first = .false. c c %--------------------------------% c | safmin = safe minimum is such | c | that 1/sfmin does not overflow | c %--------------------------------% c safmin = slamch('safmin') end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = msaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. c c %--------------------------------% c | Pointer to the current step of | c | the factorization to build | c %--------------------------------% c j = k + 1 c c %------------------------------------------% c | Pointers used for reverse communication | c | when using WORKD. | c %------------------------------------------% c ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | sgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %------------------------------% c | Else this is the first step. | c %------------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% c 1000 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, j, ndigit, & '_saitr: generating Arnoldi vector no.') call svout (logfil, 1, rnorm, ndigit, & '_saitr: B-norm of the current residual =') end if c c %---------------------------------------------------------% c | Check for exact zero. Equivalent to determing whether a | c | j-step Arnoldi factorization is present. | c %---------------------------------------------------------% c if (rnorm .gt. zero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_saitr: ****** restart at step ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call sgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call arscnd (t1) tsaitr = tsaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call scopy (n, resid, 1, v(1,j), 1) if (rnorm .ge. safmin) then temp1 = one / rnorm call sscal (n, temp1, v(1,j), 1) call sscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine SLASCL | c %-----------------------------------------% c call slascl ('General', i, i, rnorm, one, n, 1, & v(1,j), n, infol) call slascl ('General', i, i, rnorm, one, n, 1, & workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call arscnd (t2) call scopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %-----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j}. | c %-----------------------------------% c call arscnd (t3) tmvopx = tmvopx + (t3 - t2) c step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call scopy (n, workd(irj), 1, resid, 1) c c %-------------------------------------------% c | STEP 4: Finish extending the symmetric | c | Arnoldi to length j. If MODE = 2 | c | then B*OP = B*inv(B)*A = A and | c | we don't need to compute B*OP. | c | NOTE: If MODE = 2 WORKD(IVJ:IVJ+N-1) is | c | assumed to have A*v_{j}. | c %-------------------------------------------% c if (mode .eq. 2) go to 65 call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy(n, resid, 1 , workd(ipj), 1) end if 60 continue c c %-----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j}. | c %-----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c 65 continue if (mode .eq. 2) then c c %----------------------------------% c | Note that the B-norm of OP*v_{j} | c | is the inv(B)-norm of A*v_{j}. | c %----------------------------------% c wnorm = sdot (n, resid, 1, workd(ivj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'G') then wnorm = sdot (n, resid, 1, workd(ipj), 1) wnorm = sqrt(abs(wnorm)) else if (bmat .eq. 'I') then wnorm = snrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c if (mode .ne. 2 ) then call sgemv('T', n, j, one, v, ldv, workd(ipj), 1, zero, & workd(irj), 1) else if (mode .eq. 2) then call sgemv('T', n, j, one, v, ldv, workd(ivj), 1, zero, & workd(irj), 1) end if c c %--------------------------------------% c | Orthgonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call sgemv('N', n, j, -one, v, ldv, workd(irj), 1, one, & resid, 1) c c %--------------------------------------% c | Extend H to have j rows and columns. | c %--------------------------------------% c h(j,2) = workd(irj + j - 1) if (j .eq. 1 .or. rstart) then h(j,1) = zero else h(j,1) = rnorm end if call arscnd (t4) c orth1 = .true. iter = 0 c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd(ipj), 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c %-----------------------------------------------------------% c if (rnorm .gt. 0.717*wnorm) go to 100 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then xtemp(1) = wnorm xtemp(2) = rnorm call svout (logfil, 2, xtemp, ndigit, & '_saitr: re-orthonalization ; wnorm and rnorm are') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call sgemv ('T', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %----------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) + | c | v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j, but only | c | H(j,j) is updated. | c %----------------------------------------------% c call sgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) c if (j .eq. 1 .or. rstart) h(j,1) = zero h(j,2) = h(j,2) + workd(irj + j - 1) c orth2 = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then rnorm1 = sdot (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt(abs(rnorm1)) else if (bmat .eq. 'I') then rnorm1 = snrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_saitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then xtemp(1) = rnorm xtemp(2) = rnorm1 call svout (logfil, 2, xtemp, ndigit, & '_saitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if (rnorm1 .gt. 0.717*rnorm) then c c %--------------------------------% c | No need for further refinement | c %--------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = zero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call arscnd (t5) titref = titref + (t5 - t4) c c %----------------------------------------------------------% c | Make sure the last off-diagonal element is non negative | c | If not perform a similarity transformation on H(1:j,1:j) | c | and scale v(:,j) by -1. | c %----------------------------------------------------------% c if (h(j,1) .lt. zero) then h(j,1) = -h(j,1) if ( j .lt. k+np) then call sscal(n, -one, v(1,j+1), 1) else call sscal(n, -one, resid, 1) end if end if c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call arscnd (t1) tsaitr = tsaitr + (t1 - t0) ido = 99 c if (msglvl .gt. 1) then call svout (logfil, k+np, h(1,2), ndigit, & '_saitr: main diagonal of matrix H of step K+NP.') if (k+np .gt. 1) then call svout (logfil, k+np-1, h(2,1), ndigit, & '_saitr: sub diagonal of matrix H of step K+NP.') end if end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of ssaitr | c %---------------% c end arpack-akloeckner-07/SRC/ssapps.f0000644000175000017500000004373210670622032016611 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP shifts implicitly resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix of order KEV+NP. Q is the product of c rotations resulting from the NP bulge chasing sweeps. The updated Arnoldi c factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call ssapps c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. dimension of matrix A. c c KEV Integer. (INPUT) c INPUT: KEV+NP is the size of the input matrix H. c OUTPUT: KEV is the size of the updated matrix HNEW. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFT Real array of length NP. (INPUT) c The shifts to be applied. c c V Real N by (KEV+NP) array. (INPUT/OUTPUT) c INPUT: V contains the current KEV+NP Arnoldi vectors. c OUTPUT: VNEW = V(1:n,1:KEV); the updated Arnoldi vectors c are in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (KEV+NP) by 2 array. (INPUT/OUTPUT) c INPUT: H contains the symmetric tridiagonal matrix of the c Arnoldi factorization with the subdiagonal in the 1st column c starting at H(2,1) and the main diagonal in the 2nd column. c OUTPUT: H contains the updated tridiagonal matrix in the c KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Real array of length (N). (INPUT/OUTPUT) c INPUT: RESID contains the the residual vector r_{k+p}. c OUTPUT: RESID is the updated residual vector rnew_{k}. c c Q Real KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations during the bulge c chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKD Real work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c slartg LAPACK Givens rotation construction routine. c slacpy LAPACK matrix copy routine. c slaset LAPACK matrix initialization routine. c sgemv Level 2 BLAS routine for matrix vector multiplication. c saxpy Level 1 BLAS that computes a vector triad. c scopy Level 1 BLAS that copies one vector to another. c sscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: sapps.F SID: 2.6 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the subblocks of c the tridiagonal matrix H and not just to the submatrix that it c comes from. This routine assumes that the subdiagonal elements c of H that are stored in h(1:kev+np,1) are nonegative upon input c and enforce this condition upon output. This version incorporates c deflation. See code for documentation. c c\EndLib c c----------------------------------------------------------------------- c subroutine ssapps & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Real & h(ldh,2), q(ldq,kev+np), resid(n), shift(np), & v(ldv,kev+np), workd(2*n) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c integer i, iend, istart, itop, j, jj, kplusp, msglvl logical first Real & a1, a2, a3, a4, big, c, epsmch, f, g, r, s save epsmch, first c c c %----------------------% c | External Subroutines | c %----------------------% c external saxpy, scopy, sscal, slacpy, slartg, slaset, svout, & ivout, arscnd, sgemv c c %--------------------% c | External Functions | c %--------------------% c Real & slamch external slamch c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then epsmch = slamch('Epsilon-Machine') first = .false. end if itop = 1 c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = msapps c kplusp = kev + np c c %----------------------------------------------% c | Initialize Q to the identity matrix of order | c | kplusp used to accumulate the rotations. | c %----------------------------------------------% c call slaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------------------% c | Apply the np shifts implicitly. Apply each shift to the | c | whole matrix and not just to the submatrix from which it | c | comes. | c %----------------------------------------------------------% c do 90 jj = 1, np c istart = itop c c %----------------------------------------------------------% c | Check for splitting and deflation. Currently we consider | c | an off-diagonal element h(i+1,1) negligible if | c | h(i+1,1) .le. epsmch*( |h(i,2)| + |h(i+1,2)| ) | c | for i=1:KEV+NP-1. | c | If above condition tests true then we set h(i+1,1) = 0. | c | Note that h(1:KEV+NP,1) are assumed to be non negative. | c %----------------------------------------------------------% c 20 continue c c %------------------------------------------------% c | The following loop exits early if we encounter | c | a negligible off diagonal element. | c %------------------------------------------------% c do 30 i = istart, kplusp-1 big = abs(h(i,2)) + abs(h(i+1,2)) if (h(i+1,1) .le. epsmch*big) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_sapps: deflation at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_sapps: occured before shift number.') call svout (logfil, 1, h(i+1,1), ndigit, & '_sapps: the corresponding off diagonal element') end if h(i+1,1) = zero iend = i go to 40 end if 30 continue iend = kplusp 40 continue c if (istart .lt. iend) then c c %--------------------------------------------------------% c | Construct the plane rotation G'(istart,istart+1,theta) | c | that attempts to drive h(istart+1,1) to zero. | c %--------------------------------------------------------% c f = h(istart,2) - shift(jj) g = h(istart+1,1) call slartg (f, g, c, s, r) c c %-------------------------------------------------------% c | Apply rotation to the left and right of H; | c | H <- G' * H * G, where G = G(istart,istart+1,theta). | c | This will create a "bulge". | c %-------------------------------------------------------% c a1 = c*h(istart,2) + s*h(istart+1,1) a2 = c*h(istart+1,1) + s*h(istart+1,2) a4 = c*h(istart+1,2) - s*h(istart+1,1) a3 = c*h(istart+1,1) - s*h(istart,2) h(istart,2) = c*a1 + s*a2 h(istart+1,2) = c*a4 - s*a3 h(istart+1,1) = c*a3 + s*a4 c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 60 j = 1, min(istart+jj,kplusp) a1 = c*q(j,istart) + s*q(j,istart+1) q(j,istart+1) = - s*q(j,istart) + c*q(j,istart+1) q(j,istart) = a1 60 continue c c c %----------------------------------------------% c | The following loop chases the bulge created. | c | Note that the previous rotation may also be | c | done within the following loop. But it is | c | kept separate to make the distinction among | c | the bulge chasing sweeps and the first plane | c | rotation designed to drive h(istart+1,1) to | c | zero. | c %----------------------------------------------% c do 70 i = istart+1, iend-1 c c %----------------------------------------------% c | Construct the plane rotation G'(i,i+1,theta) | c | that zeros the i-th bulge that was created | c | by G(i-1,i,theta). g represents the bulge. | c %----------------------------------------------% c f = h(i,1) g = s*h(i+1,1) c c %----------------------------------% c | Final update with G(i-1,i,theta) | c %----------------------------------% c h(i+1,1) = c*h(i+1,1) call slartg (f, g, c, s, r) c c %-------------------------------------------% c | The following ensures that h(1:iend-1,1), | c | the first iend-2 off diagonal of elements | c | H, remain non negative. | c %-------------------------------------------% c if (r .lt. zero) then r = -r c = -c s = -s end if c c %--------------------------------------------% c | Apply rotation to the left and right of H; | c | H <- G * H * G', where G = G(i,i+1,theta) | c %--------------------------------------------% c h(i,1) = r c a1 = c*h(i,2) + s*h(i+1,1) a2 = c*h(i+1,1) + s*h(i+1,2) a3 = c*h(i+1,1) - s*h(i,2) a4 = c*h(i+1,2) - s*h(i+1,1) c h(i,2) = c*a1 + s*a2 h(i+1,2) = c*a4 - s*a3 h(i+1,1) = c*a3 + s*a4 c c %----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G | c %----------------------------------------------------% c do 50 j = 1, min( i+jj, kplusp ) a1 = c*q(j,i) + s*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = a1 50 continue c 70 continue c end if c c %--------------------------% c | Update the block pointer | c %--------------------------% c istart = iend + 1 c c %------------------------------------------% c | Make sure that h(iend,1) is non-negative | c | If not then set h(iend,1) <-- -h(iend,1) | c | and negate the last column of Q. | c | We have effectively carried out a | c | similarity on transformation H | c %------------------------------------------% c if (h(iend,1) .lt. zero) then h(iend,1) = -h(iend,1) call sscal(kplusp, -one, q(1,iend), 1) end if c c %--------------------------------------------------------% c | Apply the same shift to the next block if there is any | c %--------------------------------------------------------% c if (iend .lt. kplusp) go to 20 c c %-----------------------------------------------------% c | Check if we can increase the the start of the block | c %-----------------------------------------------------% c do 80 i = itop, kplusp-1 if (h(i+1,1) .gt. zero) go to 90 itop = itop + 1 80 continue c c %-----------------------------------% c | Finished applying the jj-th shift | c %-----------------------------------% c 90 continue c c %------------------------------------------% c | All shifts have been applied. Check for | c | more possible deflation that might occur | c | after the last shift is applied. | c %------------------------------------------% c do 100 i = itop, kplusp-1 big = abs(h(i,2)) + abs(h(i+1,2)) if (h(i+1,1) .le. epsmch*big) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_sapps: deflation at row/column no.') call svout (logfil, 1, h(i+1,1), ndigit, & '_sapps: the corresponding off diagonal element') end if h(i+1,1) = zero end if 100 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is not necessary if h(kev+1,1) = 0. | c %-------------------------------------------------% c if ( h(kev+1,1) .gt. zero ) & call sgemv ('N', n, kplusp, one, v, ldv, & q(1,kev+1), 1, zero, workd(n+1), 1) c c %-------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage that Q is an upper triangular matrix | c | with lower bandwidth np. | c | Place results in v(:,kplusp-kev:kplusp) temporarily. | c %-------------------------------------------------------% c do 130 i = 1, kev call sgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call scopy (n, workd, 1, v(1,kplusp-i+1), 1) 130 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call slacpy ('All', n, kev, v(1,np+1), ldv, v, ldv) c c %--------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the | c | appropriate place if h(kev+1,1) .ne. zero. | c %--------------------------------------------% c if ( h(kev+1,1) .gt. zero ) & call scopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kev+p}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call sscal (n, q(kplusp,kev), resid, 1) if (h(kev+1,1) .gt. zero) & call saxpy (n, h(kev+1,1), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call svout (logfil, 1, q(kplusp,kev), ndigit, & '_sapps: sigmak of the updated residual vector') call svout (logfil, 1, h(kev+1,1), ndigit, & '_sapps: betak of the updated residual vector') call svout (logfil, kev, h(1,2), ndigit, & '_sapps: updated main diagonal of H for next iteration') if (kev .gt. 1) then call svout (logfil, kev-1, h(2,1), ndigit, & '_sapps: updated sub diagonal of H for next iteration') end if end if c call arscnd (t1) tsapps = tsapps + (t1 - t0) c 9000 continue return c c %---------------% c | End of ssapps | c %---------------% c end arpack-akloeckner-07/SRC/ssaup2.f0000644000175000017500000007670710670622032016525 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssaup2 c c\Description: c Intermediate level interface called by ssaupd. c c\Usage: c call ssaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, c IPNTR, WORKD, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in ssaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in ssaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi/Lanczos iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV since a leading block of the current c upper Tridiagonal matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Real N by (NEV+NP) array. (INPUT/OUTPUT) c The Lanczos basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Real (NEV+NP) by 2 array. (OUTPUT) c H is used to store the generated symmetric tridiagonal matrix c The subdiagonal is stored in the first column of H starting c at H(2,1). The main diagonal is stored in the second column c of H starting at H(1,2). If ssaup2 converges store the c B-norm of the final residual vector in H(1,1). c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Real array of length NEV+NP. (OUTPUT) c RITZ(1:NEV) contains the computed Ritz values of OP. c c BOUNDS Real array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to RITZ. c c Q Real (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Real array of length at least 3*(NEV+NP). (INPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in the computation of the c tridiagonal eigenvalue problem, the calculation and c application of the shifts and convergence checking. c If ISHIFT .EQ. O and IDO .EQ. 3, the first NP locations c of WORKL are used in reverse communication to hold the user c supplied shifts. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Lanczos iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in one of c the spectral transformation modes. X is the current c operand. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Lanczos iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in ssaupd. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: All possible eigenvalues of OP has been found. c NP returns the size of the invariant subspace c spanning the operator OP. c = 2: No shifts could be applied. c = -8: Error return from trid. eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Lanczos factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c c\Routines called: c sgetv0 ARPACK initial vector generation routine. c ssaitr ARPACK Lanczos factorization routine. c ssapps ARPACK application of implicit shifts routine. c ssconv ARPACK convergence of Ritz values routine. c sseigt ARPACK compute Ritz values and error bounds routine. c ssgets ARPACK reorder Ritz values and error bounds routine. c ssortr ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c scopy Level 1 BLAS that copies one vector to another. c sdot Level 1 BLAS that computes the scalar product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c sscal Level 1 BLAS that scales a vector. c sswap Level 1 BLAS that swaps two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.4' c xx/xx/95: Version ' 2.4'. (R.B. Lehoucq) c c\SCCS Information: @(#) c FILE: saup2.F SID: 2.7 DATE OF SID: 5/19/98 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine ssaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, & q, ldq, workl, ipntr, workd, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, ldh, ldq, ldv, mxiter, & n, mode, nev, np Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Real & bounds(nev+np), h(ldh,2), q(ldq,nev+np), resid(n), & ritz(nev+np), v(ldv,nev+np), workd(3*n), & workl(3*(nev+np)) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c character wprime*2 logical cnorm, getv0, initv, update, ushift integer ierr, iter, j, kplusp, msglvl, nconv, nevbef, nev0, & np0, nptemp, nevd2, nevm2, kp(3) Real & rnorm, temp, eps23 save cnorm, getv0, initv, update, ushift, & iter, kplusp, msglvl, nconv, nev0, np0, & rnorm, eps23 c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, sgetv0, ssaitr, sscal, ssconv, sseigt, ssgets, & ssapps, ssortr, svout, ivout, arscnd, sswap c c %--------------------% c | External Functions | c %--------------------% c Real & sdot, snrm2, slamch external sdot, snrm2, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = msaup2 c c %---------------------------------% c | Set machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0/3.0E+0) c c %-------------------------------------% c | nev0 and np0 are integer variables | c | hold the initial values of NEV & NP | c %-------------------------------------% c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvlues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev0 + np0 nconv = 0 iter = 0 c c %--------------------------------------------% c | Set flags for computing the first NEV steps | c | of the Lanczos factorization. | c %--------------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call sgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. zero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1200 end if getv0 = .false. ido = 0 end if c c %------------------------------------------------------------% c | Back from reverse communication: continue with update step | c %------------------------------------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Lanczos factorization | c %----------------------------------------------------------% c call ssaitr (ido, bmat, n, 0, nev0, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then c c %-----------------------------------------------------% c | ssaitr was unable to build an Lanczos factorization | c | of length NEV0. INFO is returned with the size of | c | the factorization built. Exit main loop. | c %-----------------------------------------------------% c np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N LANCZOS I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Lanczos | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_saup2: **** Start of major iteration number ****') end if if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_saup2: The length of the current Lanczos factorization') call ivout (logfil, 1, np, ndigit, & '_saup2: Extend the Lanczos factorization by') end if c c %------------------------------------------------------------% c | Compute NP additional steps of the Lanczos factorization. | c %------------------------------------------------------------% c ido = 0 20 continue update = .true. c call ssaitr (ido, bmat, n, nev, np, mode, resid, rnorm, v, & ldv, h, ldh, ipntr, workd, info) c c %---------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP and possibly B | c %---------------------------------------------------% c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then c c %-----------------------------------------------------% c | ssaitr was unable to build an Lanczos factorization | c | of length NEV0+NP0. INFO is returned with the size | c | of the factorization built. Exit main loop. | c %-----------------------------------------------------% c np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call svout (logfil, 1, rnorm, ndigit, & '_saup2: Current B-norm of residual for factorization') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current symmetric tridiagonal matrix. | c %--------------------------------------------------------% c call sseigt (rnorm, kplusp, h, ldh, ritz, bounds, workl, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %----------------------------------------------------% c | Make a copy of eigenvalues and corresponding error | c | bounds obtained from _seigt. | c %----------------------------------------------------% c call scopy(kplusp, ritz, 1, workl(kplusp+1), 1) call scopy(kplusp, bounds, 1, workl(2*kplusp+1), 1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The selection is based on the requested number of | c | eigenvalues instead of the current NEV and NP to | c | prevent possible misconvergence. | c | * Wanted Ritz values := RITZ(NP+1:NEV+NP) | c | * Shifts := RITZ(1:NP) := WORKL(1:NP) | c %---------------------------------------------------% c nev = nev0 np = np0 call ssgets (ishift, which, nev, np, ritz, bounds, workl) c c %-------------------% c | Convergence test. | c %-------------------% c call scopy (nev, bounds(np+1), 1, workl(np+1), 1) call ssconv (nev, ritz(np+1), workl(np+1), tol, nconv) c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = nconv call ivout (logfil, 3, kp, ndigit, & '_saup2: NEV, NP, NCONV are') call svout (logfil, kplusp, ritz, ndigit, & '_saup2: The eigenvalues of H') call svout (logfil, kplusp, bounds, ndigit, & '_saup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. nev0) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP since we don't want to | c | swap overlapping locations. | c %------------------------------------------------% c if (which .eq. 'BE') then c c %-----------------------------------------------------% c | Both ends of the spectrum are requested. | c | Sort the eigenvalues into algebraically decreasing | c | order first then swap low end of the spectrum next | c | to high end in appropriate locations. | c | NOTE: when np < floor(nev/2) be careful not to swap | c | overlapping locations. | c %-----------------------------------------------------% c wprime = 'SA' call ssortr (wprime, .true., kplusp, ritz, bounds) nevd2 = nev0 / 2 nevm2 = nev0 - nevd2 if ( nev .gt. 1 ) then call sswap ( min(nevd2,np), ritz(nevm2+1), 1, & ritz( max(kplusp-nevd2+1,kplusp-np+1) ), 1) call sswap ( min(nevd2,np), bounds(nevm2+1), 1, & bounds( max(kplusp-nevd2+1,kplusp-np+1)), 1) end if c else c c %--------------------------------------------------% c | LM, SM, LA, SA case. | c | Sort the eigenvalues of H into the an order that | c | is opposite to WHICH, and apply the resulting | c | order to BOUNDS. The eigenvalues are sorted so | c | that the wanted part are always within the first | c | NEV locations. | c %--------------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LA') wprime = 'SA' if (which .eq. 'SA') wprime = 'LA' c call ssortr (wprime, .true., kplusp, ritz, bounds) c end if c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23,magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, nev0 temp = max( eps23, abs(ritz(j)) ) bounds(j) = bounds(j)/temp 35 continue c c %----------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | esitmates. This will push all the converged ones | c | towards the front of ritzr, ritzi, bounds | c | (in the case when NCONV < NEV.) | c %----------------------------------------------------% c wprime = 'LA' call ssortr(wprime, .true., nev0, bounds, ritz) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, nev0 temp = max( eps23, abs(ritz(j)) ) bounds(j) = bounds(j)*temp 40 continue c c %--------------------------------------------------% c | Sort the "converged" Ritz values again so that | c | the "threshold" values and their associated Ritz | c | estimates appear at the appropriate position in | c | ritz and bound. | c %--------------------------------------------------% c if (which .eq. 'BE') then c c %------------------------------------------------% c | Sort the "converged" Ritz values in increasing | c | order. The "threshold" values are in the | c | middle. | c %------------------------------------------------% c wprime = 'LA' call ssortr(wprime, .true., nconv, ritz, bounds) c else c c %----------------------------------------------% c | In LM, SM, LA, SA case, sort the "converged" | c | Ritz values according to WHICH so that the | c | "threshold" value appears at the front of | c | ritz. | c %----------------------------------------------% call ssortr(which, .true., nconv, ritz, bounds) c end if c c %------------------------------------------% c | Use h( 1,1 ) as storage to communicate | c | rnorm to _seupd if needed | c %------------------------------------------% c h(1,1) = rnorm c if (msglvl .gt. 1) then call svout (logfil, kplusp, ritz, ndigit, & '_saup2: Sorted Ritz values.') call svout (logfil, kplusp, bounds, ndigit, & '_saup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. nev) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. nev0) info = 2 c np = nconv go to 1100 c else if (nconv .lt. nev .and. ishift .eq. 1) then c c %---------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the number | c | of Ritz values and the shifts. | c %---------------------------------------------------% c nevbef = nev nev = nev + min (nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 2) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call ssgets (ishift, which, nev, np, ritz, bounds, & workl) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_saup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_saup2: NEV and NP are') call svout (logfil, nev, ritz(np+1), ndigit, & '_saup2: "wanted" Ritz values.') call svout (logfil, nev, bounds(np+1), ndigit, & '_saup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-----------------------------------------------------% c | User specified shifts: reverse communication to | c | compute the shifts. They are returned in the first | c | NP locations of WORKL. | c %-----------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if c 50 continue c c %------------------------------------% c | Back from reverse communication; | c | User specified shifts are returned | c | in WORKL(1:*NP) | c %------------------------------------% c ushift = .false. c c c %---------------------------------------------------------% c | Move the NP shifts to the first NP locations of RITZ to | c | free up WORKL. This is for the non-exact shift case; | c | in the exact shift case, ssgets already handles this. | c %---------------------------------------------------------% c if (ishift .eq. 0) call scopy (np, workl, 1, ritz, 1) c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_saup2: The number of shifts to apply ') call svout (logfil, np, workl, ndigit, & '_saup2: shifts selected') if (ishift .eq. 1) then call svout (logfil, np, bounds, ndigit, & '_saup2: corresponding Ritz estimates') end if end if c c %---------------------------------------------------------% c | Apply the NP0 implicit shifts by QR bulge chasing. | c | Each shift is applied to the entire tridiagonal matrix. | c | The first 2*N locations of WORKD are used as workspace. | c | After ssapps is done, we have a Lanczos | c | factorization of length NEV. | c %---------------------------------------------------------% c call ssapps (n, nev, np, ritz, v, ldv, h, ldh, resid, q, ldq, & workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to ssaitr. | c %---------------------------------------------% c cnorm = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call scopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call scopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then rnorm = sdot (n, resid, 1, workd, 1) rnorm = sqrt(abs(rnorm)) else if (bmat .eq. 'I') then rnorm = snrm2(n, resid, 1) end if cnorm = .false. 130 continue c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm, ndigit, & '_saup2: B-norm of residual for NEV factorization') call svout (logfil, nev, h(1,2), ndigit, & '_saup2: main diagonal of compressed H matrix') call svout (logfil, nev-1, h(2,1), ndigit, & '_saup2: subdiagonal of compressed H matrix') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = nconv c 1200 continue ido = 99 c c %------------% c | Error exit | c %------------% c call arscnd (t1) tsaup2 = t1 - t0 c 9000 continue return c c %---------------% c | End of ssaup2 | c %---------------% c end arpack-akloeckner-07/SRC/ssaupd.f0000644000175000017500000007037210670622032016577 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssaupd c c\Description: c c Reverse communication interface for the Implicitly Restarted Arnoldi c Iteration. For symmetric problems this reduces to a variant of the Lanczos c method. This method has been designed to compute approximations to a c few eigenpairs of a linear operator OP that is real and symmetric c with respect to a real positive semi-definite symmetric matrix B, c i.e. c c B*OP = (OP`)*B. c c Another way to express this condition is c c < x,OPy > = < OPx,y > where < z,w > = z`Bw . c c In the standard eigenproblem B is the identity matrix. c ( A` denotes transpose of A) c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c ssaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x, A symmetric c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite c ===> OP = (inv[K - sigma*M])*M and B = M. c ===> Shift-and-Invert mode c c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, c KG symmetric indefinite c ===> OP = (inv[K - sigma*KG])*K and B = K. c ===> Buckling mode c c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. c ===> Cayley transformed mode c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call ssaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to ssaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c ssaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c (If Mode = 2 see remark 5 below) c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3,4 and 5, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute the IPARAM(8) shifts where c IPNTR(11) is the pointer into WORKL for c placing the shifts. See remark 6 below. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c Specify which of the Ritz values of OP to compute. c c 'LA' - compute the NEV largest (algebraic) eigenvalues. c 'SA' - compute the NEV smallest (algebraic) eigenvalues. c 'LM' - compute the NEV largest (in magnitude) eigenvalues. c 'SM' - compute the NEV smallest (in magnitude) eigenvalues. c 'BE' - compute NEV eigenvalues, half from each end of the c spectrum. When NEV is odd, compute one more from the c high end than from the low end. c (see remark 1 below) c c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N. c c TOL Real scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). c If TOL .LE. 0. is passed a default is set: c DEFAULT = SLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine SLAMCH). c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V (less than or equal to N). c This will indicate how many Lanczos vectors are generated c at each iteration. After the startup phase in which NEV c Lanczos vectors are generated, the algorithm generates c NCV-NEV Lanczos vectors at each subsequent update iteration. c Most of the cost in generating each Lanczos vector is in the c matrix-vector product OP*x. (See remark 4 below). c c V Real N by NCV array. (OUTPUT) c The NCV columns of V contain the Lanczos basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are provided by the user via c reverse communication. The NCV eigenvalues of c the current tridiagonal matrix T are returned in c the part of WORKL array corresponding to RITZ. c See remark 6 below. c ISHIFT = 1: exact shifts with respect to the reduced c tridiagonal matrix T. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of Ritz vectors c associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = LEVEC c No longer referenced. See remark 2 below. c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4,5; See under \Description of ssaupd for the c five modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), ssaupd returns NP, the number c of shifts the user is to provide. 0 < NP <=NCV-NEV. See Remark c 6 below. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 11. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Lanczos iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by 2 tridiagonal matrix T in WORKL. c IPNTR(6): pointer to the NCV RITZ values array in WORKL. c IPNTR(7): pointer to the Ritz estimates in array WORKL associated c with the Ritz values located in RITZ in WORKL. c IPNTR(11): pointer to the NP shifts in WORKL. See Remark 6 below. c c Note: IPNTR(8:10) is only referenced by sseupd. See Remark 2. c IPNTR(8): pointer to the NCV RITZ values of the original system. c IPNTR(9): pointer to the NCV corresponding error bounds. c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors c of the tridiagonal matrix T. Only referenced by c sseupd if RVEC = .TRUE. See Remarks. c ------------------------------------------------------------- c c WORKD Real work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration. Upon termination c WORKD(1:N) contains B*RESID(1:N). If the Ritz vectors are desired c subroutine sseupd uses this output. c See Data Distribution Note below. c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least NCV**2 + 8*NCV . c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV must be greater than NEV and less than or equal to N. c = -4: The maximum number of Arnoldi update iterations allowed c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array WORKL is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Informatinal error from LAPACK routine ssteqr. c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatable. c = -12: IPARAM(1) must be equal to 0 or 1. c = -13: NEV and WHICH = 'BE' are incompatable. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current Arnoldi c factorization. The user is advised to check that c enough workspace and array storage has been allocated. c c c\Remarks c 1. The converged Ritz values are always returned in ascending c algebraic order. The computed Ritz values are approximate c eigenvalues of OP. The selection of WHICH should be made c with this in mind when Mode = 3,4,5. After convergence, c approximate eigenvalues of the original problem may be obtained c with the ARPACK subroutine sseupd. c c 2. If the Ritz vectors corresponding to the converged Ritz values c are needed, the user must call sseupd immediately following completion c of ssaupd. This is new starting with version 2.1 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requrement is that NCV > NEV. c However, it is recommended that NCV .ge. 2*NEV. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c c 5. If IPARAM(7) = 2 then in the Reverse commuication interface the user c must do the following. When IDO = 1, Y = OP * X is to be computed. c When IPARAM(7) = 2 OP = inv(B)*A. After computing A*X the user c must overwrite X with A*X. Y is then the solution to the linear set c of equations B*Y = A*X. c c 6. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) shifts in locations: c 1 WORKL(IPNTR(11)) c 2 WORKL(IPNTR(11)+1) c . c . c . c NP WORKL(IPNTR(11)+NP-1). c c The eigenvalues of the current tridiagonal matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are in the c order defined by WHICH. The associated Ritz estimates are located in c WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c REAL RESID(N), V(LDV,NCV), WORKD(3*N), WORKL(LWORKL) c DECOMPOSE D1(N), D2(N,NCV) c ALIGN RESID(I) with D1(I) c ALIGN V(I,J) with D2(I,J) c ALIGN WORKD(I) with D1(I) range (1:N) c ALIGN WORKD(I) with D1(I-N) range (N+1:2*N) c ALIGN WORKD(I) with D1(I-2*N) range (2*N+1:3*N) c DISTRIBUTE D1(BLOCK), D2(BLOCK,:) c REPLICATED WORKL(LWORKL) c c Cray MPP syntax: c =============== c REAL RESID(N), V(LDV,NCV), WORKD(N,3), WORKL(LWORKL) c SHARED RESID(BLOCK), V(BLOCK,:), WORKD(BLOCK,:) c REPLICATED WORKL(LWORKL) c c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c 8. R.B. Lehoucq, D.C. Sorensen, "Implementation of Some Spectral c Transformations in a k-Step Arnoldi Method". In Preparation. c c\Routines called: c ssaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c sstats ARPACK routine that initialize timing and other statistics c variables. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.4' c c\SCCS Information: @(#) c FILE: saupd.F SID: 2.8 DATE OF SID: 04/10/01 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine ssaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(11) Real & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0 , zero = 0.0E+0 ) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, msglvl, mxiter, mode, nb, & nev0, next, np, ritz, j save bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, msglvl, mxiter, mode, nb, & nev0, next, np, ritz c c %----------------------% c | External Subroutines | c %----------------------% c external ssaup2, svout, ivout, arscnd, sstats c c %--------------------% c | External Functions | c %--------------------% c Real & slamch external slamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call sstats call arscnd (t0) msglvl = msaupd c ierr = 0 ishift = iparam(1) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c c %----------------% c | Error checking | c %----------------% c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 end if c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c %----------------------------------------------% c np = ncv - nev c if (mxiter .le. 0) ierr = -4 if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LA' .and. & which .ne. 'SA' .and. & which .ne. 'BE') ierr = -5 if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 c if (lworkl .lt. ncv**2 + 8*ncv) ierr = -7 if (mode .lt. 1 .or. mode .gt. 5) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 else if (ishift .lt. 0 .or. ishift .gt. 1) then ierr = -12 else if (nev .eq. 1 .and. which .eq. 'BE') then ierr = -13 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. zero) tol = slamch('EpsMach') c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, ncv**2 + 8*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:2*ncv) := generated tridiagonal matrix | c | workl(2*ncv+1:2*ncv+ncv) := ritz values | c | workl(3*ncv+1:3*ncv+ncv) := computed error bounds | c | workl(4*ncv+1:4*ncv+ncv*ncv) := rotation matrix Q | c | workl(4*ncv+ncv*ncv+1:7*ncv+ncv*ncv) := workspace | c %-------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritz = ih + 2*ldh bounds = ritz + ncv iq = bounds + ncv iw = iq + ncv**2 next = iw + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritz ipntr(7) = bounds ipntr(11) = iw end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Lanczos Iteration. | c %-------------------------------------------------------% c call ssaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), & workl(bounds), workl(iq), ldq, workl(iw), ipntr, workd, & info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP or shifts. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within ssaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_saupd: number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_saupd: number of "converged" Ritz values') call svout (logfil, np, workl(Ritz), ndigit, & '_saupd: final Ritz values') call svout (logfil, np, workl(Bounds), ndigit, & '_saupd: corresponding error bounds') end if c call arscnd (t1) tsaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tsaupd, tsaup2, tsaitr, titref, & tgetv0, tseigt, tsgets, tsapps, tsconv 1000 format (//, & 5x, '==========================================',/ & 5x, '= Symmetric implicit Arnoldi update code =',/ & 5x, '= Version Number:', ' 2.4' , 19x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96' , 14x, ' =',/ & 5x, '==========================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '==========================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in saup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in trid eigenvalue subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6) end if c 9000 continue c return c c %---------------% c | End of ssaupd | c %---------------% c end arpack-akloeckner-07/SRC/ssconv.f0000644000175000017500000000645610670622032016615 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssconv c c\Description: c Convergence testing for the symmetric Arnoldi eigenvalue routine. c c\Usage: c call ssconv c ( N, RITZ, BOUNDS, TOL, NCONV ) c c\Arguments c N Integer. (INPUT) c Number of Ritz values to check for convergence. c c RITZ Real array of length N. (INPUT) c The Ritz values to be checked for convergence. c c BOUNDS Real array of length N. (INPUT) c Ritz estimates associated with the Ritz values in RITZ. c c TOL Real scalar. (INPUT) c Desired relative accuracy for a Ritz value to be considered c "converged". c c NCONV Integer scalar. (OUTPUT) c Number of "converged" Ritz values. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines called: c arscnd ARPACK utility routine for timing. c slamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sconv.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 c c\Remarks c 1. Starting with version 2.4, this routine no longer uses the c Parlett strategy using the gap conditions. c c\EndLib c c----------------------------------------------------------------------- c subroutine ssconv (n, ritz, bounds, tol, nconv) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer n, nconv Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c Real & ritz(n), bounds(n) c c %---------------% c | Local Scalars | c %---------------% c integer i Real & temp, eps23 c c %-------------------% c | External routines | c %-------------------% c Real & slamch external slamch c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c call arscnd (t0) c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0) c nconv = 0 do 10 i = 1, n c c %-----------------------------------------------------% c | The i-th Ritz value is considered "converged" | c | when: bounds(i) .le. TOL*max(eps23, abs(ritz(i))) | c %-----------------------------------------------------% c temp = max( eps23, abs(ritz(i)) ) if ( bounds(i) .le. tol*temp ) then nconv = nconv + 1 end if c 10 continue c call arscnd (t1) tsconv = tsconv + (t1 - t0) c return c c %---------------% c | End of ssconv | c %---------------% c end arpack-akloeckner-07/SRC/sseigt.f0000644000175000017500000001175510670622032016576 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: sseigt c c\Description: c Compute the eigenvalues of the current symmetric tridiagonal matrix c and the corresponding error bounds given the current residual norm. c c\Usage: c call sseigt c ( RNORM, N, H, LDH, EIG, BOUNDS, WORKL, IERR ) c c\Arguments c RNORM Real scalar. (INPUT) c RNORM contains the residual norm corresponding to the current c symmetric tridiagonal matrix H. c c N Integer. (INPUT) c Size of the symmetric tridiagonal matrix H. c c H Real N by 2 array. (INPUT) c H contains the symmetric tridiagonal matrix with the c subdiagonal in the first column starting at H(2,1) and the c main diagonal in second column. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c EIG Real array of length N. (OUTPUT) c On output, EIG contains the N eigenvalues of H possibly c unsorted. The BOUNDS arrays are returned in the c same sorted order as EIG. c c BOUNDS Real array of length N. (OUTPUT) c On output, BOUNDS contains the error estimates corresponding c to the eigenvalues EIG. This is equal to RNORM times the c last components of the eigenvectors corresponding to the c eigenvalues in EIG. c c WORKL Real work array of length 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c IERR Integer. (OUTPUT) c Error exit flag from sstqrb. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c sstqrb ARPACK routine that computes the eigenvalues and the c last components of the eigenvectors of a symmetric c and tridiagonal matrix. c arscnd ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c scopy Level 1 BLAS that copies one vector to another. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.4' c c\SCCS Information: @(#) c FILE: seigt.F SID: 2.4 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine sseigt & ( rnorm, n, h, ldh, eig, bounds, workl, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, ldh, n Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Real & eig(n), bounds(n), h(ldh,2), workl(3*n) c c %------------% c | Parameters | c %------------% c Real & zero parameter (zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c integer i, k, msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external scopy, sstqrb, svout, arscnd c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mseigt c if (msglvl .gt. 0) then call svout (logfil, n, h(1,2), ndigit, & '_seigt: main diagonal of matrix H') if (n .gt. 1) then call svout (logfil, n-1, h(2,1), ndigit, & '_seigt: sub diagonal of matrix H') end if end if c call scopy (n, h(1,2), 1, eig, 1) call scopy (n-1, h(2,1), 1, workl, 1) call sstqrb (n, eig, workl, bounds, workl(n+1), ierr) if (ierr .ne. 0) go to 9000 if (msglvl .gt. 1) then call svout (logfil, n, bounds, ndigit, & '_seigt: last row of the eigenvector matrix for H') end if c c %-----------------------------------------------% c | Finally determine the error bounds associated | c | with the n Ritz values of H. | c %-----------------------------------------------% c do 30 k = 1, n bounds(k) = rnorm*abs(bounds(k)) 30 continue c call arscnd (t1) tseigt = tseigt + (t1 - t0) c 9000 continue return c c %---------------% c | End of sseigt | c %---------------% c end arpack-akloeckner-07/SRC/sseupd.f0000644000175000017500000010265407264674530016621 0ustar andreasandreasc\BeginDoc c c\Name: sseupd c c\Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) the corresponding approximate eigenvectors, c c (2) an orthonormal (Lanczos) basis for the associated approximate c invariant subspace, c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c (Lanczos) basis is always computed. There is an additional storage cost c of n*nev if both are requested (in this case a separate array Z must be c supplied). c c These quantities are obtained from the Lanczos factorization computed c by SSAUPD for the linear operator OP prescribed by the MODE selection c (see IPARAM(7) in SSAUPD documentation.) SSAUPD must be called before c this routine is called. These approximate eigenvalues and vectors are c commonly called Ritz values and Ritz vectors respectively. They are c referred to as such in the comments that follow. The computed orthonormal c basis for the invariant subspace corresponding to these Ritz values is c referred to as a Lanczos basis. c c See documentation in the header of the subroutine SSAUPD for a definition c of OP as well as other terms and the relation of computed Ritz values c and vectors of OP with respect to the given problem A*z = lambda*B*z. c c The approximate eigenvalues of the original problem are returned in c ascending algebraic order. The user may elect to call this routine c once for each desired Ritz vector and store it peripherally if desired. c There is also the option of computing a selected set of these vectors c with a single call. c c\Usage: c call sseupd c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) c c RVEC LOGICAL (INPUT) c Specifies whether Ritz vectors corresponding to the Ritz value c approximations to the eigenproblem A*z = lambda*B*z are computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors. c c HOWMNY Character*1 (INPUT) c Specifies how many Ritz vectors are wanted and the form of Z c the matrix of Ritz vectors. See remark 1 below. c = 'A': compute NEV Ritz vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' , SELECT is used as a workspace for c reordering the Ritz values. c c D Real array of dimension NEV. (OUTPUT) c On exit, D contains the Ritz value approximations to the c eigenvalues of A*z = lambda*B*z. The values are returned c in ascending order. If IPARAM(7) = 3,4,5 then D represents c the Ritz values of OP computed by ssaupd transformed to c those of the original eigensystem A*z = lambda*B*z. If c IPARAM(7) = 1,2 then the Ritz values of OP are the same c as the those of A*z = lambda*B*z. c c Z Real N by NEV array if HOWMNY = 'A'. (OUTPUT) c On exit, Z contains the B-orthonormal Ritz vectors of the c eigensystem A*z = lambda*B*z corresponding to the Ritz c value approximations. c If RVEC = .FALSE. then Z is not referenced. c NOTE: The array Z may be set equal to first NEV columns of the c Arnoldi/Lanczos basis array V computed by SSAUPD. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. c c SIGMA Real (INPUT) c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if c IPARAM(7) = 1 or 2. c c c **** The remaining arguments MUST be the same as for the **** c **** call to SSAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, INFO c c must be passed directly to SSEUPD following the last call c to SSAUPD. These arguments MUST NOT BE MODIFIED between c the the last call to SSAUPD and the call to SSEUPD. c c Two of these parameters (WORKL, INFO) are also output parameters: c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:4*ncv) contains information obtained in c ssaupd. They are not changed by sseupd. c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the c untransformed Ritz values, the computed error estimates, c and the associated eigenvector matrix of H. c c Note: IPNTR(8:10) contains the pointer into WORKL for addresses c of the above information computed by sseupd. c ------------------------------------------------------------- c IPNTR(8): pointer to the NCV RITZ values of the original system. c IPNTR(9): pointer to the NCV corresponding error bounds. c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors c of the tridiagonal matrix T. Only referenced by c sseupd if RVEC = .TRUE. See Remarks. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c = 0: Normal exit. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV must be greater than NEV and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Information error from LAPACK routine ssteqr. c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: NEV and WHICH = 'BE' are incompatible. c = -14: SSAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. c = -16: HOWMNY = 'S' not yet implemented c = -17: SSEUPD got a different count of the number of converged c Ritz values than SSAUPD got. This indicates the user c probably made an error in passing data from SSAUPD to c SSEUPD or that the data was modified before entering c SSEUPD. c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c c\Remarks c 1. The converged Ritz values are always returned in increasing c (algebraic) order. c c 2. Currently only HOWMNY = 'A' is implemented. It is included at this c stage for the user who wants to incorporate it. c c\Routines called: c ssesrt ARPACK routine that sorts an array X, and applies the c corresponding permutation to a matrix A. c ssortr ssortr ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c svout ARPACK utility routine that prints vectors. c sgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c slacpy LAPACK matrix copy routine. c slamch LAPACK routine that determines machine constants. c sorm2r LAPACK routine that applies an orthogonal matrix in c factored form. c ssteqr LAPACK routine that computes eigenvalues and eigenvectors c of a tridiagonal matrix. c sger Level 2 BLAS rank one update to a matrix. c scopy Level 1 BLAS that copies one vector to another . c snrm2 Level 1 BLAS that computes the norm of a vector. c sscal Level 1 BLAS that scales a vector. c sswap Level 1 BLAS that swaps the contents of two vectors. c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.1' c c\SCCS Information: @(#) c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine sseupd(rvec , howmny, select, d , & z , ldz , sigma , bmat , & n , which , nev , tol , & resid , ncv , v , ldv , & iparam, ipntr , workd , workl, & lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Real & sigma, tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(7), ipntr(11) logical select(ncv) Real & d(nev) , resid(n) , v(ldv,ncv), & z(ldz, nev), workd(2*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0 , zero = 0.0E+0 ) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds , ierr , ih , ihb , ihd , & iq , iw , j , k , ldh , & ldq , mode , msglvl, nconv , next , & ritz , irz , ibd , np , ishift, & leftptr, rghtptr, numcnv, jj Real & bnorm2 , rnorm, temp, temp1, eps23 logical reord c c %----------------------% c | External Subroutines | c %----------------------% c external scopy , sger , sgeqr2, slacpy, sorm2r, sscal, & ssesrt, ssteqr, sswap , svout , ivout , ssortr c c %--------------------% c | External Functions | c %--------------------% c Real & snrm2, slamch external snrm2, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mseupd mode = iparam(7) nconv = iparam(5) info = 0 c c %--------------% c | Quick return | c %--------------% c if (nconv .eq. 0) go to 9000 ierr = 0 c if (nconv .le. 0) ierr = -14 if (n .le. 0) ierr = -1 if (nev .le. 0) ierr = -2 if (ncv .le. nev .or. ncv .gt. n) ierr = -3 if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LA' .and. & which .ne. 'SA' .and. & which .ne. 'BE') ierr = -5 if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) & ierr = -15 if (rvec .and. howmny .eq. 'S') ierr = -16 c if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 ) then type = 'SHIFTI' else if (mode .eq. 4 ) then type = 'BUCKLE' else if (mode .eq. 5 ) then type = 'CAYLEY' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %-------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:2*ncv) := generated tridiagonal matrix H | c | The subdiagonal is stored in workl(2:ncv). | c | The dead spot is workl(1) but upon exiting | c | ssaupd stores the B-norm of the last residual | c | vector in workl(1). We use this !!! | c | workl(2*ncv+1:2*ncv+ncv) := ritz values | c | The wanted values are in the first NCONV spots. | c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | c | The wanted values are in the first NCONV spots. | c | NOTE: workl(1:4*ncv) is set by ssaupd and is not | c | modified by sseupd. | c %-------------------------------------------------------% c c %-------------------------------------------------------% c | The following is used and set by sseupd. | c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | c | computation of the eigenvectors of H. Stores | c | the diagonal of H. Upon EXIT contains the NCV | c | Ritz values of the original system. The first | c | NCONV spots have the wanted values. If MODE = | c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | c | computation of the eigenvectors of H. Stores | c | the subdiagonal of H. Upon EXIT contains the | c | NCV corresponding Ritz estimates of the | c | original system. The first NCONV spots have the | c | wanted values. If MODE = 1,2 then will equal | c | workl(3*ncv+1:4*ncv). | c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | c | the eigenvector matrix for H as returned by | c | ssteqr. Not referenced if RVEC = .False. | c | Ordering follows that of workl(4*ncv+1:5*ncv) | c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | c | Workspace. Needed by ssteqr and by sseupd. | c | GRAND total of NCV*(NCV+8) locations. | c %-------------------------------------------------------% c c ih = ipntr(5) ritz = ipntr(6) bounds = ipntr(7) ldh = ncv ldq = ncv ihd = bounds + ldh ihb = ihd + ldh iq = ihb + ldh iw = iq + ldh*ncv next = iw + 2*ncv ipntr(4) = next ipntr(8) = ihd ipntr(9) = ihb ipntr(10) = iq c c %----------------------------------------% c | irz points to the Ritz values computed | c | by _seigt before exiting _saup2. | c | ibd points to the Ritz estimates | c | computed by _seigt before exiting | c | _saup2. | c %----------------------------------------% c irz = ipntr(11)+ncv ibd = irz+ncv c c c %---------------------------------% c | Set machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0 ) c c %---------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c | BNORM2 is the 2 norm of B*RESID(1:N). | c | Upon exit of ssaupd WORKD(1:N) has | c | B*RESID(1:N). | c %---------------------------------------% c rnorm = workl(ih) if (bmat .eq. 'I') then bnorm2 = rnorm else if (bmat .eq. 'G') then bnorm2 = snrm2(n, workd, 1) end if c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(irz), ndigit, & '_seupd: Ritz values passed in from _SAUPD.') call svout(logfil, ncv, workl(ibd), ndigit, & '_seupd: Ritz estimates passed in from _SAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(bound) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call ssgets(ishift, which , nev , & np , workl(irz) , workl(bounds), & workl) c if (msglvl .gt. 2) then call svout(logfil, ncv, workl(irz), ndigit, & '_seupd: Ritz values after calling _SGETS.') call svout(logfil, ncv, workl(bounds), ndigit, & '_seupd: Ritz value indices after calling _SGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv temp1 = max(eps23, abs(workl(irz+ncv-j)) ) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & workl(ibd+jj-1) .le. tol*temp1) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by _saupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the _saupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_seupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_seupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -17 go to 9000 end if c c %-----------------------------------------------------------% c | Call LAPACK routine _steqr to compute the eigenvalues and | c | eigenvectors of the final symmetric tridiagonal matrix H. | c | Initialize the eigenvector matrix Q to the identity. | c %-----------------------------------------------------------% c call scopy(ncv-1, workl(ih+1), 1, workl(ihb), 1) call scopy(ncv, workl(ih+ldh), 1, workl(ihd), 1) c call ssteqr('Identity', ncv, workl(ihd), workl(ihb), & workl(iq) , ldq, workl(iw), ierr) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call scopy(ncv, workl(iq+ncv-1), ldq, workl(iw), 1) call svout(logfil, ncv, workl(ihd), ndigit, & '_seupd: NCV Ritz values of the final H matrix') call svout(logfil, ncv, workl(iw), ndigit, & '_seupd: last row of the eigenvector matrix for H') end if c if (reord) then c c %---------------------------------------------% c | Reordered the eigenvalues and eigenvectors | c | computed by _steqr so that the "converged" | c | eigenvalues appear in the first NCONV | c | positions of workl(ihd), and the associated | c | eigenvectors appear in the first NCONV | c | columns. | c %---------------------------------------------% c leftptr = 1 rghtptr = ncv c if (ncv .eq. 1) go to 30 c 20 if (select(leftptr)) then c c %-------------------------------------------% c | Search, from the left, for the first Ritz | c | value that has not converged. | c %-------------------------------------------% c leftptr = leftptr + 1 c else if ( .not. select(rghtptr)) then c c %----------------------------------------------% c | Search, from the right, the first Ritz value | c | that has converged. | c %----------------------------------------------% c rghtptr = rghtptr - 1 c else c c %----------------------------------------------% c | Swap the Ritz value on the left that has not | c | converged with the Ritz value on the right | c | that has converged. Swap the associated | c | eigenvector of the tridiagonal matrix H as | c | well. | c %----------------------------------------------% c temp = workl(ihd+leftptr-1) workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) workl(ihd+rghtptr-1) = temp call scopy(ncv, workl(iq+ncv*(leftptr-1)), 1, & workl(iw), 1) call scopy(ncv, workl(iq+ncv*(rghtptr-1)), 1, & workl(iq+ncv*(leftptr-1)), 1) call scopy(ncv, workl(iw), 1, & workl(iq+ncv*(rghtptr-1)), 1) leftptr = leftptr + 1 rghtptr = rghtptr - 1 c end if c if (leftptr .lt. rghtptr) go to 20 c 30 end if c if (msglvl .gt. 2) then call svout (logfil, ncv, workl(ihd), ndigit, & '_seupd: The eigenvalues of H--reordered') end if c c %----------------------------------------% c | Load the converged Ritz values into D. | c %----------------------------------------% c call scopy(nconv, workl(ihd), 1, d, 1) c else c c %-----------------------------------------------------% c | Ritz vectors not required. Load Ritz values into D. | c %-----------------------------------------------------% c call scopy(nconv, workl(ritz), 1, d, 1) call scopy(ncv, workl(ritz), 1, workl(ihd), 1) c end if c c %------------------------------------------------------------------% c | Transform the Ritz values and possibly vectors and corresponding | c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | c | (and corresponding data) are returned in ascending order. | c %------------------------------------------------------------------% c if (type .eq. 'REGULR') then c c %---------------------------------------------------------% c | Ascending sort of wanted Ritz values, vectors and error | c | bounds. Not necessary if only Ritz values are desired. | c %---------------------------------------------------------% c if (rvec) then call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq) else call scopy(ncv, workl(bounds), 1, workl(ihb), 1) end if c else c c %-------------------------------------------------------------% c | * Make a copy of all the Ritz values. | c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | For TYPE = 'BUCKLE' the transformation is | c | lambda = sigma * theta / ( theta - 1 ) | c | For TYPE = 'CAYLEY' the transformation is | c | lambda = sigma * (theta + 1) / (theta - 1 ) | c | where the theta are the Ritz values returned by ssaupd. | c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c | They are only reordered. | c %-------------------------------------------------------------% c call scopy (ncv, workl(ihd), 1, workl(iw), 1) if (type .eq. 'SHIFTI') then do 40 k=1, ncv workl(ihd+k-1) = one / workl(ihd+k-1) + sigma 40 continue else if (type .eq. 'BUCKLE') then do 50 k=1, ncv workl(ihd+k-1) = sigma * workl(ihd+k-1) / & (workl(ihd+k-1) - one) 50 continue else if (type .eq. 'CAYLEY') then do 60 k=1, ncv workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / & (workl(ihd+k-1) - one) 60 continue end if c c %-------------------------------------------------------------% c | * Store the wanted NCONV lambda values into D. | c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | c | into ascending order and apply sort to the NCONV theta | c | values in the transformed system. We will need this to | c | compute Ritz estimates in the original system. | c | * Finally sort the lambda`s into ascending order and apply | c | to Ritz vectors if wanted. Else just sort lambda`s into | c | ascending order. | c | NOTES: | c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | c | match the ordering of the lambda. We`ll use them again for | c | Ritz vector purification. | c %-------------------------------------------------------------% c call scopy(nconv, workl(ihd), 1, d, 1) call ssortr('LA', .true., nconv, workl(ihd), workl(iw)) if (rvec) then call ssesrt('LA', rvec , nconv, d, ncv, workl(iq), ldq) else call scopy(ncv, workl(bounds), 1, workl(ihb), 1) call sscal(ncv, bnorm2/rnorm, workl(ihb), 1) call ssortr('LA', .true., nconv, d, workl(ihb)) end if c end if c c %------------------------------------------------% c | Compute the Ritz vectors. Transform the wanted | c | eigenvectors of the symmetric tridiagonal H by | c | the Lanczos basis matrix V. | c %------------------------------------------------% c if (rvec .and. howmny .eq. 'A') then c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(iq,ldq). | c %----------------------------------------------------------% c call sgeqr2(ncv, nconv , workl(iq) , & ldq, workl(iw+ncv), workl(ihb), & ierr) c c %--------------------------------------------------------% c | * Postmultiply V by Q. | c | * Copy the first NCONV columns of VQ into Z. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(ihd). | c %--------------------------------------------------------% c call sorm2r('Right', 'Notranspose', n , & ncv , nconv , workl(iq), & ldq , workl(iw+ncv), v , & ldv , workd(n+1) , ierr) call slacpy('All', n, nconv, v, ldv, z, ldz) c c %-----------------------------------------------------% c | In order to compute the Ritz estimates for the Ritz | c | values in both systems, need the last row of the | c | eigenvector matrix. Remember, it`s in factored form | c %-----------------------------------------------------% c do 65 j = 1, ncv-1 workl(ihb+j-1) = zero 65 continue workl(ihb+ncv-1) = one call sorm2r('Left', 'Transpose' , ncv , & 1 , nconv , workl(iq) , & ldq , workl(iw+ncv), workl(ihb), & ncv , temp , ierr) c else if (rvec .and. howmny .eq. 'S') then c c Not yet implemented. See remark 2 above. c end if c if (type .eq. 'REGULR' .and. rvec) then c do 70 j=1, ncv workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) 70 continue c else if (type .ne. 'REGULR' .and. rvec) then c c %-------------------------------------------------% c | * Determine Ritz estimates of the theta. | c | If RVEC = .true. then compute Ritz estimates | c | of the theta. | c | If RVEC = .false. then copy Ritz estimates | c | as computed by ssaupd. | c | * Determine Ritz estimates of the lambda. | c %-------------------------------------------------% c call sscal (ncv, bnorm2, workl(ihb), 1) if (type .eq. 'SHIFTI') then c do 80 k=1, ncv workl(ihb+k-1) = abs( workl(ihb+k-1) ) & / workl(iw+k-1)**2 80 continue c else if (type .eq. 'BUCKLE') then c do 90 k=1, ncv workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) & / (workl(iw+k-1)-one )**2 90 continue c else if (type .eq. 'CAYLEY') then c do 100 k=1, ncv workl(ihb+k-1) = abs( workl(ihb+k-1) & / workl(iw+k-1)*(workl(iw+k-1)-one) ) 100 continue c end if c end if c if (type .ne. 'REGULR' .and. msglvl .gt. 1) then call svout(logfil, nconv, d, ndigit, & '_seupd: Untransformed converged Ritz values') call svout(logfil, nconv, workl(ihb), ndigit, & '_seupd: Ritz estimates of the untransformed Ritz values') else if (msglvl .gt. 1) then call svout(logfil, nconv, d, ndigit, & '_seupd: Converged Ritz values') call svout(logfil, nconv, workl(ihb), ndigit, & '_seupd: Associated Ritz estimates') end if c c %-------------------------------------------------% c | Ritz vector purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 3,4,5. See reference 7 | c %-------------------------------------------------% c if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then c do 110 k=0, nconv-1 workl(iw+k) = workl(iq+k*ldq+ncv-1) & / workl(iw+k) 110 continue c else if (rvec .and. type .eq. 'BUCKLE') then c do 120 k=0, nconv-1 workl(iw+k) = workl(iq+k*ldq+ncv-1) & / (workl(iw+k)-one) 120 continue c end if c if (type .ne. 'REGULR') & call sger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) c 9000 continue c return c c %---------------% c | End of sseupd| c %---------------% c end arpack-akloeckner-07/SRC/ssgets.f0000644000175000017500000001634110670622032016604 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssgets c c\Description: c Given the eigenvalues of the symmetric tridiagonal matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: This is called even in the case of user specified shifts in c order to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call ssgets c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS, SHIFTS ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> KEV eigenvalues of largest magnitude are retained. c 'SM' -> KEV eigenvalues of smallest magnitude are retained. c 'LA' -> KEV eigenvalues of largest value are retained. c 'SA' -> KEV eigenvalues of smallest value are retained. c 'BE' -> KEV eigenvalues, half from each end of the spectrum. c If KEV is odd, compute one more from the high end. c c KEV Integer. (INPUT) c KEV+NP is the size of the matrix H. c c NP Integer. (INPUT) c Number of implicit shifts to be computed. c c RITZ Real array of length KEV+NP. (INPUT/OUTPUT) c On INPUT, RITZ contains the eigenvalues of H. c On OUTPUT, RITZ are sorted so that the unwanted eigenvalues c are in the first NP locations and the wanted part is in c the last KEV locations. When exact shifts are selected, the c unwanted part corresponds to the shifts to be applied. c c BOUNDS Real array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c SHIFTS Real array of length NP. (INPUT/OUTPUT) c On INPUT: contains the user specified shifts if ISHIFT = 0. c On OUTPUT: contains the shifts sorted into decreasing order c of magnitude with respect to the Ritz estimates contained in c BOUNDS. If ISHIFT = 0, SHIFTS is not modified on exit. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c ssortr ARPACK utility sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c svout ARPACK utility routine that prints vectors. c scopy Level 1 BLAS that copies one vector to another. c sswap Level 1 BLAS that swaps the contents of two vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/93: Version ' 2.1' c c\SCCS Information: @(#) c FILE: sgets.F SID: 2.4 DATE OF SID: 4/19/96 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine ssgets ( ishift, which, kev, np, ritz, bounds, shifts ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Real & bounds(kev+np), ritz(kev+np), shifts(np) c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %---------------% c | Local Scalars | c %---------------% c integer kevd2, msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external sswap, scopy, ssortr, arscnd c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic max, min c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = msgets c if (which .eq. 'BE') then c c %-----------------------------------------------------% c | Both ends of the spectrum are requested. | c | Sort the eigenvalues into algebraically increasing | c | order first then swap high end of the spectrum next | c | to low end in appropriate locations. | c | NOTE: when np < floor(kev/2) be careful not to swap | c | overlapping locations. | c %-----------------------------------------------------% c call ssortr ('LA', .true., kev+np, ritz, bounds) kevd2 = kev / 2 if ( kev .gt. 1 ) then call sswap ( min(kevd2,np), ritz, 1, & ritz( max(kevd2,np)+1 ), 1) call sswap ( min(kevd2,np), bounds, 1, & bounds( max(kevd2,np)+1 ), 1) end if c else c c %----------------------------------------------------% c | LM, SM, LA, SA case. | c | Sort the eigenvalues of H into the desired order | c | and apply the resulting order to BOUNDS. | c | The eigenvalues are sorted so that the wanted part | c | are always in the last KEV locations. | c %----------------------------------------------------% c call ssortr (which, .true., kev+np, ritz, bounds) end if c if (ishift .eq. 1 .and. np .gt. 0) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first. | c | This will tend to minimize the effects of the | c | forward instability of the iteration when the shifts | c | are applied in subroutine ssapps. | c %-------------------------------------------------------% c call ssortr ('SM', .true., np, bounds, ritz) call scopy (np, ritz, 1, shifts, 1) end if c call arscnd (t1) tsgets = tsgets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_sgets: KEV is') call ivout (logfil, 1, np, ndigit, '_sgets: NP is') call svout (logfil, kev+np, ritz, ndigit, & '_sgets: Eigenvalues of current H matrix') call svout (logfil, kev+np, bounds, ndigit, & '_sgets: Associated Ritz estimates') end if c return c c %---------------% c | End of ssgets | c %---------------% c end arpack-akloeckner-07/SRC/ssortc.f0000644000175000017500000002175206136210162016612 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssortc c c\Description: c Sorts the complex array in XREAL and XIMAG into the order c specified by WHICH and optionally applies the permutation to the c real array Y. It is assumed that if an element of XIMAG is c nonzero, then its negative is also an element. In other words, c both members of a complex conjugate pair are to be sorted and the c pairs are kept adjacent to each other. c c\Usage: c call ssortc c ( WHICH, APPLY, N, XREAL, XIMAG, Y ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> sort XREAL,XIMAG into increasing order of magnitude. c 'SM' -> sort XREAL,XIMAG into decreasing order of magnitude. c 'LR' -> sort XREAL into increasing order of algebraic. c 'SR' -> sort XREAL into decreasing order of algebraic. c 'LI' -> sort XIMAG into increasing order of magnitude. c 'SI' -> sort XIMAG into decreasing order of magnitude. c NOTE: If an element of XIMAG is non-zero, then its negative c is also an element. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to array Y. c APPLY = .FALSE. -> do not apply the sorted order to array Y. c c N Integer. (INPUT) c Size of the arrays. c c XREAL, Real array of length N. (INPUT/OUTPUT) c XIMAG Real and imaginary part of the array to be sorted. c c Y Real array of length N. (INPUT/OUTPUT) c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c xx/xx/92: Version ' 2.1' c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortc.F SID: 2.3 DATE OF SID: 4/20/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine ssortc (which, apply, n, xreal, ximag, y) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Real & xreal(0:n-1), ximag(0:n-1), y(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Real & temp, temp1, temp2 c c %--------------------% c | External Functions | c %--------------------% c Real & slapy2 external slapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'LM') then c c %------------------------------------------------------% c | Sort XREAL,XIMAG into increasing order of magnitude. | c %------------------------------------------------------% c 10 continue if (igap .eq. 0) go to 9000 c do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c temp1 = slapy2(xreal(j),ximag(j)) temp2 = slapy2(xreal(j+igap),ximag(j+igap)) c if (temp1.gt.temp2) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 30 end if j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c %------------------------------------------------------% c | Sort XREAL,XIMAG into decreasing order of magnitude. | c %------------------------------------------------------% c 40 continue if (igap .eq. 0) go to 9000 c do 60 i = igap, n-1 j = i-igap 50 continue c if (j .lt. 0) go to 60 c temp1 = slapy2(xreal(j),ximag(j)) temp2 = slapy2(xreal(j+igap),ximag(j+igap)) c if (temp1.lt.temp2) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LR') then c c %------------------------------------------------% c | Sort XREAL into increasing order of algebraic. | c %------------------------------------------------% c 70 continue if (igap .eq. 0) go to 9000 c do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (xreal(j).gt.xreal(j+igap)) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'SR') then c c %------------------------------------------------% c | Sort XREAL into decreasing order of algebraic. | c %------------------------------------------------% c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (xreal(j).lt.xreal(j+igap)) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 c else if (which .eq. 'LI') then c c %------------------------------------------------% c | Sort XIMAG into increasing order of magnitude. | c %------------------------------------------------% c 130 continue if (igap .eq. 0) go to 9000 do 150 i = igap, n-1 j = i-igap 140 continue c if (j.lt.0) go to 150 c if (abs(ximag(j)).gt.abs(ximag(j+igap))) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 150 endif j = j-igap go to 140 150 continue igap = igap / 2 go to 130 c else if (which .eq. 'SI') then c c %------------------------------------------------% c | Sort XIMAG into decreasing order of magnitude. | c %------------------------------------------------% c 160 continue if (igap .eq. 0) go to 9000 do 180 i = igap, n-1 j = i-igap 170 continue c if (j.lt.0) go to 180 c if (abs(ximag(j)).lt.abs(ximag(j+igap))) then temp = xreal(j) xreal(j) = xreal(j+igap) xreal(j+igap) = temp c temp = ximag(j) ximag(j) = ximag(j+igap) ximag(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 180 endif j = j-igap go to 170 180 continue igap = igap / 2 go to 160 end if c 9000 continue return c c %---------------% c | End of ssortc | c %---------------% c end arpack-akloeckner-07/SRC/ssortr.f0000644000175000017500000001227406136210163016631 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: ssortr c c\Description: c Sort the array X1 in the order specified by WHICH and optionally c applies the permutation to the array X2. c c\Usage: c call ssortr c ( WHICH, APPLY, N, X1, X2 ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> X1 is sorted into increasing order of magnitude. c 'SM' -> X1 is sorted into decreasing order of magnitude. c 'LA' -> X1 is sorted into increasing order of algebraic. c 'SA' -> X1 is sorted into decreasing order of algebraic. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to X2. c APPLY = .FALSE. -> do not apply the sorted order to X2. c c N Integer. (INPUT) c Size of the arrays. c c X1 Real array of length N. (INPUT/OUTPUT) c The array to be sorted. c c X2 Real array of length N. (INPUT/OUTPUT) c Only referenced if APPLY = .TRUE. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/16/93: Version ' 2.1'. c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortr.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine ssortr (which, apply, n, x1, x2) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Real & x1(0:n-1), x2(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Real & temp c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'SA') then c c X1 is sorted into decreasing order of algebraic. c 10 continue if (igap .eq. 0) go to 9000 do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c if (x1(j).lt.x1(j+igap)) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 30 endif j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c X1 is sorted into decreasing order of magnitude. c 40 continue if (igap .eq. 0) go to 9000 do 60 i = igap, n-1 j = i-igap 50 continue c if (j.lt.0) go to 60 c if (abs(x1(j)).lt.abs(x1(j+igap))) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LA') then c c X1 is sorted into increasing order of algebraic. c 70 continue if (igap .eq. 0) go to 9000 do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (x1(j).gt.x1(j+igap)) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'LM') then c c X1 is sorted into increasing order of magnitude. c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (abs(x1(j)).gt.abs(x1(j+igap))) then temp = x1(j) x1(j) = x1(j+igap) x1(j+igap) = temp if (apply) then temp = x2(j) x2(j) = x2(j+igap) x2(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 end if c 9000 continue return c c %---------------% c | End of ssortr | c %---------------% c end arpack-akloeckner-07/SRC/sstatn.f0000644000175000017500000000271006136210163016603 0ustar andreasandreasc c %---------------------------------------------% c | Initialize statistic and timing information | c | for nonsymmetric Arnoldi code. | c %---------------------------------------------% c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: statn.F SID: 2.4 DATE OF SID: 4/20/96 RELEASE: 2 c subroutine sstatn c c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c include 'stat.h' c c %-----------------------% c | Executable Statements | c %-----------------------% c nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 c tnaupd = 0.0E+0 tnaup2 = 0.0E+0 tnaitr = 0.0E+0 tneigh = 0.0E+0 tngets = 0.0E+0 tnapps = 0.0E+0 tnconv = 0.0E+0 titref = 0.0E+0 tgetv0 = 0.0E+0 trvec = 0.0E+0 c c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% c tmvopx = 0.0E+0 tmvbx = 0.0E+0 c return c c c %---------------% c | End of sstatn | c %---------------% c end arpack-akloeckner-07/SRC/sstats.f0000644000175000017500000000221606136210164016612 0ustar andreasandreasc c\SCCS Information: @(#) c FILE: stats.F SID: 2.1 DATE OF SID: 4/19/96 RELEASE: 2 c %---------------------------------------------% c | Initialize statistic and timing information | c | for symmetric Arnoldi code. | c %---------------------------------------------% subroutine sstats c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% include 'stat.h' c %-----------------------% c | Executable Statements | c %-----------------------% nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 tsaupd = 0.0E+0 tsaup2 = 0.0E+0 tsaitr = 0.0E+0 tseigt = 0.0E+0 tsgets = 0.0E+0 tsapps = 0.0E+0 tsconv = 0.0E+0 titref = 0.0E+0 tgetv0 = 0.0E+0 trvec = 0.0E+0 c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% tmvopx = 0.0E+0 tmvbx = 0.0E+0 return c c End of sstats c end arpack-akloeckner-07/SRC/sstqrb.f0000644000175000017500000004046406210503745016621 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: sstqrb c c\Description: c Computes all eigenvalues and the last component of the eigenvectors c of a symmetric tridiagonal matrix using the implicit QL or QR method. c c This is mostly a modification of the LAPACK routine ssteqr. c See Remarks. c c\Usage: c call sstqrb c ( N, D, E, Z, WORK, INFO ) c c\Arguments c N Integer. (INPUT) c The number of rows and columns in the matrix. N >= 0. c c D Real array, dimension (N). (INPUT/OUTPUT) c On entry, D contains the diagonal elements of the c tridiagonal matrix. c On exit, D contains the eigenvalues, in ascending order. c If an error exit is made, the eigenvalues are correct c for indices 1,2,...,INFO-1, but they are unordered and c may not be the smallest eigenvalues of the matrix. c c E Real array, dimension (N-1). (INPUT/OUTPUT) c On entry, E contains the subdiagonal elements of the c tridiagonal matrix in positions 1 through N-1. c On exit, E has been destroyed. c c Z Real array, dimension (N). (OUTPUT) c On exit, Z contains the last row of the orthonormal c eigenvector matrix of the symmetric tridiagonal matrix. c If an error exit is made, Z contains the last row of the c eigenvector matrix associated with the stored eigenvalues. c c WORK Real array, dimension (max(1,2*N-2)). (WORKSPACE) c Workspace used in accumulating the transformation for c computing the last components of the eigenvectors. c c INFO Integer. (OUTPUT) c = 0: normal return. c < 0: if INFO = -i, the i-th argument had an illegal value. c > 0: if INFO = +i, the i-th eigenvalue has not converged c after a total of 30*N iterations. c c\Remarks c 1. None. c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx real c c\Routines called: c saxpy Level 1 BLAS that computes a vector triad. c scopy Level 1 BLAS that copies one vector to another. c sswap Level 1 BLAS that swaps the contents of two vectors. c lsame LAPACK character comparison routine. c slae2 LAPACK routine that computes the eigenvalues of a 2-by-2 c symmetric matrix. c slaev2 LAPACK routine that eigendecomposition of a 2-by-2 symmetric c matrix. c slamch LAPACK routine that determines machine constants. c slanst LAPACK routine that computes the norm of a matrix. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slartg LAPACK Givens rotation construction routine. c slascl LAPACK routine for careful scaling of a matrix. c slaset LAPACK matrix initialization routine. c slasr LAPACK routine that applies an orthogonal transformation to c a matrix. c slasrt LAPACK sorting routine. c ssteqr LAPACK routine that computes eigenvalues and eigenvectors c of a symmetric tridiagonal matrix. c xerbla LAPACK error handler routine. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: stqrb.F SID: 2.5 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c 1. Starting with version 2.5, this routine is a modified version c of LAPACK version 2.0 subroutine SSTEQR. No lines are deleted, c only commeted out and new lines inserted. c All lines commented out have "c$$$" at the beginning. c Note that the LAPACK version 1.0 subroutine SSTEQR contained c bugs. c c\EndLib c c----------------------------------------------------------------------- c subroutine sstqrb ( n, d, e, z, work, info ) c c %------------------% c | Scalar Arguments | c %------------------% c integer info, n c c %-----------------% c | Array Arguments | c %-----------------% c Real & d( n ), e( n-1 ), z( n ), work( 2*n-2 ) c c .. parameters .. Real & zero, one, two, three parameter ( zero = 0.0E+0, one = 1.0E+0, & two = 2.0E+0, three = 3.0E+0 ) integer maxit parameter ( maxit = 30 ) c .. c .. local scalars .. integer i, icompz, ii, iscale, j, jtot, k, l, l1, lend, & lendm1, lendp1, lendsv, lm1, lsv, m, mm, mm1, & nm1, nmaxit Real & anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, & s, safmax, safmin, ssfmax, ssfmin, tst c .. c .. external functions .. logical lsame Real & slamch, slanst, slapy2 external lsame, slamch, slanst, slapy2 c .. c .. external subroutines .. external slae2, slaev2, slartg, slascl, slaset, slasr, & slasrt, sswap, xerbla c .. c .. intrinsic functions .. intrinsic abs, max, sign, sqrt c .. c .. executable statements .. c c test the input parameters. c info = 0 c c$$$ IF( LSAME( COMPZ, 'N' ) ) THEN c$$$ ICOMPZ = 0 c$$$ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN c$$$ ICOMPZ = 1 c$$$ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN c$$$ ICOMPZ = 2 c$$$ ELSE c$$$ ICOMPZ = -1 c$$$ END IF c$$$ IF( ICOMPZ.LT.0 ) THEN c$$$ INFO = -1 c$$$ ELSE IF( N.LT.0 ) THEN c$$$ INFO = -2 c$$$ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, c$$$ $ N ) ) ) THEN c$$$ INFO = -6 c$$$ END IF c$$$ IF( INFO.NE.0 ) THEN c$$$ CALL XERBLA( 'SSTEQR', -INFO ) c$$$ RETURN c$$$ END IF c c *** New starting with version 2.5 *** c icompz = 2 c ************************************* c c quick return if possible c if( n.eq.0 ) $ return c if( n.eq.1 ) then if( icompz.eq.2 ) z( 1 ) = one return end if c c determine the unit roundoff and over/underflow thresholds. c eps = slamch( 'e' ) eps2 = eps**2 safmin = slamch( 's' ) safmax = one / safmin ssfmax = sqrt( safmax ) / three ssfmin = sqrt( safmin ) / eps2 c c compute the eigenvalues and eigenvectors of the tridiagonal c matrix. c c$$ if( icompz.eq.2 ) c$$$ $ call slaset( 'full', n, n, zero, one, z, ldz ) c c *** New starting with version 2.5 *** c if ( icompz .eq. 2 ) then do 5 j = 1, n-1 z(j) = zero 5 continue z( n ) = one end if c ************************************* c nmaxit = n*maxit jtot = 0 c c determine where the matrix splits and choose ql or qr iteration c for each block, according to whether top or bottom diagonal c element is smaller. c l1 = 1 nm1 = n - 1 c 10 continue if( l1.gt.n ) $ go to 160 if( l1.gt.1 ) $ e( l1-1 ) = zero if( l1.le.nm1 ) then do 20 m = l1, nm1 tst = abs( e( m ) ) if( tst.eq.zero ) $ go to 30 if( tst.le.( sqrt( abs( d( m ) ) )*sqrt( abs( d( m+ $ 1 ) ) ) )*eps ) then e( m ) = zero go to 30 end if 20 continue end if m = n c 30 continue l = l1 lsv = l lend = m lendsv = lend l1 = m + 1 if( lend.eq.l ) $ go to 10 c c scale submatrix in rows and columns l to lend c anorm = slanst( 'i', lend-l+1, d( l ), e( l ) ) iscale = 0 if( anorm.eq.zero ) $ go to 10 if( anorm.gt.ssfmax ) then iscale = 1 call slascl( 'g', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, $ info ) call slascl( 'g', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, $ info ) else if( anorm.lt.ssfmin ) then iscale = 2 call slascl( 'g', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, $ info ) call slascl( 'g', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, $ info ) end if c c choose between ql and qr iteration c if( abs( d( lend ) ).lt.abs( d( l ) ) ) then lend = lsv l = lendsv end if c if( lend.gt.l ) then c c ql iteration c c look for small subdiagonal element. c 40 continue if( l.ne.lend ) then lendm1 = lend - 1 do 50 m = l, lendm1 tst = abs( e( m ) )**2 if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m+1 ) )+ $ safmin )go to 60 50 continue end if c m = lend c 60 continue if( m.lt.lend ) $ e( m ) = zero p = d( l ) if( m.eq.l ) $ go to 80 c c if remaining matrix is 2-by-2, use slae2 or slaev2 c to compute its eigensystem. c if( m.eq.l+1 ) then if( icompz.gt.0 ) then call slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s c$$$ call slasr( 'r', 'v', 'b', n, 2, work( l ), c$$$ $ work( n-1+l ), z( 1, l ), ldz ) c c *** New starting with version 2.5 *** c tst = z(l+1) z(l+1) = c*tst - s*z(l) z(l) = s*tst + c*z(l) c ************************************* else call slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 e( l ) = zero l = l + 2 if( l.le.lend ) $ go to 40 go to 140 end if c if( jtot.eq.nmaxit ) $ go to 140 jtot = jtot + 1 c c form shift. c g = ( d( l+1 )-p ) / ( two*e( l ) ) r = slapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) c s = one c = one p = zero c c inner loop c mm1 = m - 1 do 70 i = mm1, l, -1 f = s*e( i ) b = c*e( i ) call slartg( g, f, c, s, r ) if( i.ne.m-1 ) $ e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b p = s*r d( i+1 ) = g + p g = c*r - b c c if eigenvectors are desired, then save rotations. c if( icompz.gt.0 ) then work( i ) = c work( n-1+i ) = -s end if c 70 continue c c if eigenvectors are desired, then apply saved rotations. c if( icompz.gt.0 ) then mm = m - l + 1 c$$$ call slasr( 'r', 'v', 'b', n, mm, work( l ), work( n-1+l ), c$$$ $ z( 1, l ), ldz ) c c *** New starting with version 2.5 *** c call slasr( 'r', 'v', 'b', 1, mm, work( l ), & work( n-1+l ), z( l ), 1 ) c ************************************* end if c d( l ) = d( l ) - p e( l ) = g go to 40 c c eigenvalue found. c 80 continue d( l ) = p c l = l + 1 if( l.le.lend ) $ go to 40 go to 140 c else c c qr iteration c c look for small superdiagonal element. c 90 continue if( l.ne.lend ) then lendp1 = lend + 1 do 100 m = l, lendp1, -1 tst = abs( e( m-1 ) )**2 if( tst.le.( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+ $ safmin )go to 110 100 continue end if c m = lend c 110 continue if( m.gt.lend ) $ e( m-1 ) = zero p = d( l ) if( m.eq.l ) $ go to 130 c c if remaining matrix is 2-by-2, use slae2 or slaev2 c to compute its eigensystem. c if( m.eq.l-1 ) then if( icompz.gt.0 ) then call slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) c$$$ work( m ) = c c$$$ work( n-1+m ) = s c$$$ call slasr( 'r', 'v', 'f', n, 2, work( m ), c$$$ $ work( n-1+m ), z( 1, l-1 ), ldz ) c c *** New starting with version 2.5 *** c tst = z(l) z(l) = c*tst - s*z(l-1) z(l-1) = s*tst + c*z(l-1) c ************************************* else call slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 e( l-1 ) = zero l = l - 2 if( l.ge.lend ) $ go to 90 go to 140 end if c if( jtot.eq.nmaxit ) $ go to 140 jtot = jtot + 1 c c form shift. c g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) r = slapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) c s = one c = one p = zero c c inner loop c lm1 = l - 1 do 120 i = m, lm1 f = s*e( i ) b = c*e( i ) call slartg( g, f, c, s, r ) if( i.ne.m ) $ e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b p = s*r d( i ) = g + p g = c*r - b c c if eigenvectors are desired, then save rotations. c if( icompz.gt.0 ) then work( i ) = c work( n-1+i ) = s end if c 120 continue c c if eigenvectors are desired, then apply saved rotations. c if( icompz.gt.0 ) then mm = l - m + 1 c$$$ call slasr( 'r', 'v', 'f', n, mm, work( m ), work( n-1+m ), c$$$ $ z( 1, m ), ldz ) c c *** New starting with version 2.5 *** c call slasr( 'r', 'v', 'f', 1, mm, work( m ), work( n-1+m ), & z( m ), 1 ) c ************************************* end if c d( l ) = d( l ) - p e( lm1 ) = g go to 90 c c eigenvalue found. c 130 continue d( l ) = p c l = l - 1 if( l.ge.lend ) $ go to 90 go to 140 c end if c c undo scaling if necessary c 140 continue if( iscale.eq.1 ) then call slascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, $ d( lsv ), n, info ) call slascl( 'g', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ), $ n, info ) else if( iscale.eq.2 ) then call slascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, $ d( lsv ), n, info ) call slascl( 'g', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ), $ n, info ) end if c c check for no convergence to an eigenvalue after a total c of n*maxit iterations. c if( jtot.lt.nmaxit ) $ go to 10 do 150 i = 1, n - 1 if( e( i ).ne.zero ) $ info = info + 1 150 continue go to 190 c c order eigenvalues and eigenvectors. c 160 continue if( icompz.eq.0 ) then c c use quick sort c call slasrt( 'i', n, d, info ) c else c c use selection sort to minimize swaps of eigenvectors c do 180 ii = 2, n i = ii - 1 k = i p = d( i ) do 170 j = ii, n if( d( j ).lt.p ) then k = j p = d( j ) end if 170 continue if( k.ne.i ) then d( k ) = d( i ) d( i ) = p c$$$ call sswap( n, z( 1, i ), 1, z( 1, k ), 1 ) c *** New starting with version 2.5 *** c p = z(k) z(k) = z(i) z(i) = p c ************************************* end if 180 continue end if c 190 continue return c c %---------------% c | End of sstqrb | c %---------------% c end arpack-akloeckner-07/SRC/debug.h0000644000175000017500000000135106053006227016361 0ustar andreasandreasc c\SCCS Information: @(#) c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 c c %---------------------------------% c | See debug.doc for documentation | c %---------------------------------% integer logfil, ndigit, mgetv0, & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd common /debug/ & logfil, ndigit, mgetv0, & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd arpack-akloeckner-07/SRC/stat.h0000644000175000017500000000171306053006426016251 0ustar andreasandreasc %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c c\SCCS Information: @(#) c FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 c real t0, t1, t2, t3, t4, t5 save t0, t1, t2, t3, t4, t5 c integer nopx, nbx, nrorth, nitref, nrstrt real tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, & tmvopx, tmvbx, tgetv0, titref, trvec common /timing/ & nopx, nbx, nrorth, nitref, nrstrt, & tsaupd, tsaup2, tsaitr, tseigt, tsgets, tsapps, tsconv, & tnaupd, tnaup2, tnaitr, tneigh, tngets, tnapps, tnconv, & tcaupd, tcaup2, tcaitr, tceigh, tcgets, tcapps, tcconv, & tmvopx, tmvbx, tgetv0, titref, trvec arpack-akloeckner-07/SRC/dseupd.f0000644000175000017500000010320007264674531016567 0ustar andreasandreasc\BeginDoc c c\Name: dseupd c c\Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) the corresponding approximate eigenvectors, c c (2) an orthonormal (Lanczos) basis for the associated approximate c invariant subspace, c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c (Lanczos) basis is always computed. There is an additional storage cost c of n*nev if both are requested (in this case a separate array Z must be c supplied). c c These quantities are obtained from the Lanczos factorization computed c by DSAUPD for the linear operator OP prescribed by the MODE selection c (see IPARAM(7) in DSAUPD documentation.) DSAUPD must be called before c this routine is called. These approximate eigenvalues and vectors are c commonly called Ritz values and Ritz vectors respectively. They are c referred to as such in the comments that follow. The computed orthonormal c basis for the invariant subspace corresponding to these Ritz values is c referred to as a Lanczos basis. c c See documentation in the header of the subroutine DSAUPD for a definition c of OP as well as other terms and the relation of computed Ritz values c and vectors of OP with respect to the given problem A*z = lambda*B*z. c c The approximate eigenvalues of the original problem are returned in c ascending algebraic order. The user may elect to call this routine c once for each desired Ritz vector and store it peripherally if desired. c There is also the option of computing a selected set of these vectors c with a single call. c c\Usage: c call dseupd c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, BMAT, N, WHICH, NEV, TOL, c RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, WORKL, LWORKL, INFO ) c c RVEC LOGICAL (INPUT) c Specifies whether Ritz vectors corresponding to the Ritz value c approximations to the eigenproblem A*z = lambda*B*z are computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors. c c HOWMNY Character*1 (INPUT) c Specifies how many Ritz vectors are wanted and the form of Z c the matrix of Ritz vectors. See remark 1 below. c = 'A': compute NEV Ritz vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT/WORKSPACE) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' , SELECT is used as a workspace for c reordering the Ritz values. c c D Double precision array of dimension NEV. (OUTPUT) c On exit, D contains the Ritz value approximations to the c eigenvalues of A*z = lambda*B*z. The values are returned c in ascending order. If IPARAM(7) = 3,4,5 then D represents c the Ritz values of OP computed by dsaupd transformed to c those of the original eigensystem A*z = lambda*B*z. If c IPARAM(7) = 1,2 then the Ritz values of OP are the same c as the those of A*z = lambda*B*z. c c Z Double precision N by NEV array if HOWMNY = 'A'. (OUTPUT) c On exit, Z contains the B-orthonormal Ritz vectors of the c eigensystem A*z = lambda*B*z corresponding to the Ritz c value approximations. c If RVEC = .FALSE. then Z is not referenced. c NOTE: The array Z may be set equal to first NEV columns of the c Arnoldi/Lanczos basis array V computed by DSAUPD . c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. c c SIGMA Double precision (INPUT) c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if c IPARAM(7) = 1 or 2. c c c **** The remaining arguments MUST be the same as for the **** c **** call to DSAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, INFO c c must be passed directly to DSEUPD following the last call c to DSAUPD . These arguments MUST NOT BE MODIFIED between c the the last call to DSAUPD and the call to DSEUPD . c c Two of these parameters (WORKL, INFO) are also output parameters: c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:4*ncv) contains information obtained in c dsaupd . They are not changed by dseupd . c WORKL(4*ncv+1:ncv*ncv+8*ncv) holds the c untransformed Ritz values, the computed error estimates, c and the associated eigenvector matrix of H. c c Note: IPNTR(8:10) contains the pointer into WORKL for addresses c of the above information computed by dseupd . c ------------------------------------------------------------- c IPNTR(8): pointer to the NCV RITZ values of the original system. c IPNTR(9): pointer to the NCV corresponding error bounds. c IPNTR(10): pointer to the NCV by NCV matrix of eigenvectors c of the tridiagonal matrix T. Only referenced by c dseupd if RVEC = .TRUE. See Remarks. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c = 0: Normal exit. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV must be greater than NEV and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LA', 'SA' or 'BE'. c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Information error from LAPACK routine dsteqr . c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: NEV and WHICH = 'BE' are incompatible. c = -14: DSAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: HOWMNY must be one of 'A' or 'S' if RVEC = .true. c = -16: HOWMNY = 'S' not yet implemented c = -17: DSEUPD got a different count of the number of converged c Ritz values than DSAUPD got. This indicates the user c probably made an error in passing data from DSAUPD to c DSEUPD or that the data was modified before entering c DSEUPD . c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett, "The Symmetric Eigenvalue Problem". Prentice-Hall, c 1980. c 4. B.N. Parlett, B. Nour-Omid, "Towards a Black Box Lanczos Program", c Computer Physics Communications, 53 (1989), pp 169-179. c 5. B. Nour-Omid, B.N. Parlett, T. Ericson, P.S. Jensen, "How to c Implement the Spectral Transformation", Math. Comp., 48 (1987), c pp 663-673. c 6. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c 7. L. Reichel, W.B. Gragg, "Algorithm 686: FORTRAN Subroutines c for Updating the QR decomposition", ACM TOMS, December 1990, c Volume 16 Number 4, pp 369-377. c c\Remarks c 1. The converged Ritz values are always returned in increasing c (algebraic) order. c c 2. Currently only HOWMNY = 'A' is implemented. It is included at this c stage for the user who wants to incorporate it. c c\Routines called: c dsesrt ARPACK routine that sorts an array X, and applies the c corresponding permutation to a matrix A. c dsortr dsortr ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c dvout ARPACK utility routine that prints vectors. c dgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c dlacpy LAPACK matrix copy routine. c dlamch LAPACK routine that determines machine constants. c dorm2r LAPACK routine that applies an orthogonal matrix in c factored form. c dsteqr LAPACK routine that computes eigenvalues and eigenvectors c of a tridiagonal matrix. c dger Level 2 BLAS rank one update to a matrix. c dcopy Level 1 BLAS that copies one vector to another . c dnrm2 Level 1 BLAS that computes the norm of a vector. c dscal Level 1 BLAS that scales a vector. c dswap Level 1 BLAS that swaps the contents of two vectors. c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.1' c c\SCCS Information: @(#) c FILE: seupd.F SID: 2.11 DATE OF SID: 04/10/01 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine dseupd (rvec , howmny, select, d , & z , ldz , sigma , bmat , & n , which , nev , tol , & resid , ncv , v , ldv , & iparam, ipntr , workd , workl, & lworkl, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Double precision & sigma, tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(7), ipntr(11) logical select(ncv) Double precision & d(nev) , resid(n) , v(ldv,ncv), & z(ldz, nev), workd(2*n), workl(lworkl) c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0 , zero = 0.0D+0 ) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds , ierr , ih , ihb , ihd , & iq , iw , j , k , ldh , & ldq , mode , msglvl, nconv , next , & ritz , irz , ibd , np , ishift, & leftptr, rghtptr, numcnv, jj Double precision & bnorm2 , rnorm, temp, temp1, eps23 logical reord c c %----------------------% c | External Subroutines | c %----------------------% c external dcopy , dger , dgeqr2 , dlacpy , dorm2r , dscal , & dsesrt , dsteqr , dswap , dvout , ivout , dsortr c c %--------------------% c | External Functions | c %--------------------% c Double precision & dnrm2 , dlamch external dnrm2 , dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic min c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mseupd mode = iparam(7) nconv = iparam(5) info = 0 c c %--------------% c | Quick return | c %--------------% c if (nconv .eq. 0) go to 9000 ierr = 0 c if (nconv .le. 0) ierr = -14 if (n .le. 0) ierr = -1 if (nev .le. 0) ierr = -2 if (ncv .le. nev .or. ncv .gt. n) ierr = -3 if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LA' .and. & which .ne. 'SA' .and. & which .ne. 'BE') ierr = -5 if (bmat .ne. 'I' .and. bmat .ne. 'G') ierr = -6 if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) & ierr = -15 if (rvec .and. howmny .eq. 'S') ierr = -16 c if (rvec .and. lworkl .lt. ncv**2+8*ncv) ierr = -7 c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 ) then type = 'SHIFTI' else if (mode .eq. 4 ) then type = 'BUCKLE' else if (mode .eq. 5 ) then type = 'CAYLEY' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 if (nev .eq. 1 .and. which .eq. 'BE') ierr = -12 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %-------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:2*ncv) := generated tridiagonal matrix H | c | The subdiagonal is stored in workl(2:ncv). | c | The dead spot is workl(1) but upon exiting | c | dsaupd stores the B-norm of the last residual | c | vector in workl(1). We use this !!! | c | workl(2*ncv+1:2*ncv+ncv) := ritz values | c | The wanted values are in the first NCONV spots. | c | workl(3*ncv+1:3*ncv+ncv) := computed Ritz estimates | c | The wanted values are in the first NCONV spots. | c | NOTE: workl(1:4*ncv) is set by dsaupd and is not | c | modified by dseupd . | c %-------------------------------------------------------% c c %-------------------------------------------------------% c | The following is used and set by dseupd . | c | workl(4*ncv+1:4*ncv+ncv) := used as workspace during | c | computation of the eigenvectors of H. Stores | c | the diagonal of H. Upon EXIT contains the NCV | c | Ritz values of the original system. The first | c | NCONV spots have the wanted values. If MODE = | c | 1 or 2 then will equal workl(2*ncv+1:3*ncv). | c | workl(5*ncv+1:5*ncv+ncv) := used as workspace during | c | computation of the eigenvectors of H. Stores | c | the subdiagonal of H. Upon EXIT contains the | c | NCV corresponding Ritz estimates of the | c | original system. The first NCONV spots have the | c | wanted values. If MODE = 1,2 then will equal | c | workl(3*ncv+1:4*ncv). | c | workl(6*ncv+1:6*ncv+ncv*ncv) := orthogonal Q that is | c | the eigenvector matrix for H as returned by | c | dsteqr . Not referenced if RVEC = .False. | c | Ordering follows that of workl(4*ncv+1:5*ncv) | c | workl(6*ncv+ncv*ncv+1:6*ncv+ncv*ncv+2*ncv) := | c | Workspace. Needed by dsteqr and by dseupd . | c | GRAND total of NCV*(NCV+8) locations. | c %-------------------------------------------------------% c c ih = ipntr(5) ritz = ipntr(6) bounds = ipntr(7) ldh = ncv ldq = ncv ihd = bounds + ldh ihb = ihd + ldh iq = ihb + ldh iw = iq + ldh*ncv next = iw + 2*ncv ipntr(4) = next ipntr(8) = ihd ipntr(9) = ihb ipntr(10) = iq c c %----------------------------------------% c | irz points to the Ritz values computed | c | by _seigt before exiting _saup2. | c | ibd points to the Ritz estimates | c | computed by _seigt before exiting | c | _saup2. | c %----------------------------------------% c irz = ipntr(11)+ncv ibd = irz+ncv c c c %---------------------------------% c | Set machine dependent constant. | c %---------------------------------% c eps23 = dlamch ('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0 ) c c %---------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c | BNORM2 is the 2 norm of B*RESID(1:N). | c | Upon exit of dsaupd WORKD(1:N) has | c | B*RESID(1:N). | c %---------------------------------------% c rnorm = workl(ih) if (bmat .eq. 'I') then bnorm2 = rnorm else if (bmat .eq. 'G') then bnorm2 = dnrm2 (n, workd, 1) end if c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(irz), ndigit, & '_seupd: Ritz values passed in from _SAUPD.') call dvout (logfil, ncv, workl(ibd), ndigit, & '_seupd: Ritz estimates passed in from _SAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(bound) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call dsgets (ishift, which , nev , & np , workl(irz) , workl(bounds), & workl) c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(irz), ndigit, & '_seupd: Ritz values after calling _SGETS.') call dvout (logfil, ncv, workl(bounds), ndigit, & '_seupd: Ritz value indices after calling _SGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv temp1 = max(eps23, abs(workl(irz+ncv-j)) ) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & workl(ibd+jj-1) .le. tol*temp1) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by _saupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the _saupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_seupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_seupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -17 go to 9000 end if c c %-----------------------------------------------------------% c | Call LAPACK routine _steqr to compute the eigenvalues and | c | eigenvectors of the final symmetric tridiagonal matrix H. | c | Initialize the eigenvector matrix Q to the identity. | c %-----------------------------------------------------------% c call dcopy (ncv-1, workl(ih+1), 1, workl(ihb), 1) call dcopy (ncv, workl(ih+ldh), 1, workl(ihd), 1) c call dsteqr ('Identity', ncv, workl(ihd), workl(ihb), & workl(iq) , ldq, workl(iw), ierr) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call dcopy (ncv, workl(iq+ncv-1), ldq, workl(iw), 1) call dvout (logfil, ncv, workl(ihd), ndigit, & '_seupd: NCV Ritz values of the final H matrix') call dvout (logfil, ncv, workl(iw), ndigit, & '_seupd: last row of the eigenvector matrix for H') end if c if (reord) then c c %---------------------------------------------% c | Reordered the eigenvalues and eigenvectors | c | computed by _steqr so that the "converged" | c | eigenvalues appear in the first NCONV | c | positions of workl(ihd), and the associated | c | eigenvectors appear in the first NCONV | c | columns. | c %---------------------------------------------% c leftptr = 1 rghtptr = ncv c if (ncv .eq. 1) go to 30 c 20 if (select(leftptr)) then c c %-------------------------------------------% c | Search, from the left, for the first Ritz | c | value that has not converged. | c %-------------------------------------------% c leftptr = leftptr + 1 c else if ( .not. select(rghtptr)) then c c %----------------------------------------------% c | Search, from the right, the first Ritz value | c | that has converged. | c %----------------------------------------------% c rghtptr = rghtptr - 1 c else c c %----------------------------------------------% c | Swap the Ritz value on the left that has not | c | converged with the Ritz value on the right | c | that has converged. Swap the associated | c | eigenvector of the tridiagonal matrix H as | c | well. | c %----------------------------------------------% c temp = workl(ihd+leftptr-1) workl(ihd+leftptr-1) = workl(ihd+rghtptr-1) workl(ihd+rghtptr-1) = temp call dcopy (ncv, workl(iq+ncv*(leftptr-1)), 1, & workl(iw), 1) call dcopy (ncv, workl(iq+ncv*(rghtptr-1)), 1, & workl(iq+ncv*(leftptr-1)), 1) call dcopy (ncv, workl(iw), 1, & workl(iq+ncv*(rghtptr-1)), 1) leftptr = leftptr + 1 rghtptr = rghtptr - 1 c end if c if (leftptr .lt. rghtptr) go to 20 c 30 end if c if (msglvl .gt. 2) then call dvout (logfil, ncv, workl(ihd), ndigit, & '_seupd: The eigenvalues of H--reordered') end if c c %----------------------------------------% c | Load the converged Ritz values into D. | c %----------------------------------------% c call dcopy (nconv, workl(ihd), 1, d, 1) c else c c %-----------------------------------------------------% c | Ritz vectors not required. Load Ritz values into D. | c %-----------------------------------------------------% c call dcopy (nconv, workl(ritz), 1, d, 1) call dcopy (ncv, workl(ritz), 1, workl(ihd), 1) c end if c c %------------------------------------------------------------------% c | Transform the Ritz values and possibly vectors and corresponding | c | Ritz estimates of OP to those of A*x=lambda*B*x. The Ritz values | c | (and corresponding data) are returned in ascending order. | c %------------------------------------------------------------------% c if (type .eq. 'REGULR') then c c %---------------------------------------------------------% c | Ascending sort of wanted Ritz values, vectors and error | c | bounds. Not necessary if only Ritz values are desired. | c %---------------------------------------------------------% c if (rvec) then call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) else call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) end if c else c c %-------------------------------------------------------------% c | * Make a copy of all the Ritz values. | c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | For TYPE = 'BUCKLE' the transformation is | c | lambda = sigma * theta / ( theta - 1 ) | c | For TYPE = 'CAYLEY' the transformation is | c | lambda = sigma * (theta + 1) / (theta - 1 ) | c | where the theta are the Ritz values returned by dsaupd . | c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c | They are only reordered. | c %-------------------------------------------------------------% c call dcopy (ncv, workl(ihd), 1, workl(iw), 1) if (type .eq. 'SHIFTI') then do 40 k=1, ncv workl(ihd+k-1) = one / workl(ihd+k-1) + sigma 40 continue else if (type .eq. 'BUCKLE') then do 50 k=1, ncv workl(ihd+k-1) = sigma * workl(ihd+k-1) / & (workl(ihd+k-1) - one) 50 continue else if (type .eq. 'CAYLEY') then do 60 k=1, ncv workl(ihd+k-1) = sigma * (workl(ihd+k-1) + one) / & (workl(ihd+k-1) - one) 60 continue end if c c %-------------------------------------------------------------% c | * Store the wanted NCONV lambda values into D. | c | * Sort the NCONV wanted lambda in WORKL(IHD:IHD+NCONV-1) | c | into ascending order and apply sort to the NCONV theta | c | values in the transformed system. We will need this to | c | compute Ritz estimates in the original system. | c | * Finally sort the lambda`s into ascending order and apply | c | to Ritz vectors if wanted. Else just sort lambda`s into | c | ascending order. | c | NOTES: | c | *workl(iw:iw+ncv-1) contain the theta ordered so that they | c | match the ordering of the lambda. We`ll use them again for | c | Ritz vector purification. | c %-------------------------------------------------------------% c call dcopy (nconv, workl(ihd), 1, d, 1) call dsortr ('LA', .true., nconv, workl(ihd), workl(iw)) if (rvec) then call dsesrt ('LA', rvec , nconv, d, ncv, workl(iq), ldq) else call dcopy (ncv, workl(bounds), 1, workl(ihb), 1) call dscal (ncv, bnorm2/rnorm, workl(ihb), 1) call dsortr ('LA', .true., nconv, d, workl(ihb)) end if c end if c c %------------------------------------------------% c | Compute the Ritz vectors. Transform the wanted | c | eigenvectors of the symmetric tridiagonal H by | c | the Lanczos basis matrix V. | c %------------------------------------------------% c if (rvec .and. howmny .eq. 'A') then c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(iq,ldq). | c %----------------------------------------------------------% c call dgeqr2 (ncv, nconv , workl(iq) , & ldq, workl(iw+ncv), workl(ihb), & ierr) c c %--------------------------------------------------------% c | * Postmultiply V by Q. | c | * Copy the first NCONV columns of VQ into Z. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(ihd). | c %--------------------------------------------------------% c call dorm2r ('Right', 'Notranspose', n , & ncv , nconv , workl(iq), & ldq , workl(iw+ncv), v , & ldv , workd(n+1) , ierr) call dlacpy ('All', n, nconv, v, ldv, z, ldz) c c %-----------------------------------------------------% c | In order to compute the Ritz estimates for the Ritz | c | values in both systems, need the last row of the | c | eigenvector matrix. Remember, it`s in factored form | c %-----------------------------------------------------% c do 65 j = 1, ncv-1 workl(ihb+j-1) = zero 65 continue workl(ihb+ncv-1) = one call dorm2r ('Left', 'Transpose' , ncv , & 1 , nconv , workl(iq) , & ldq , workl(iw+ncv), workl(ihb), & ncv , temp , ierr) c else if (rvec .and. howmny .eq. 'S') then c c Not yet implemented. See remark 2 above. c end if c if (type .eq. 'REGULR' .and. rvec) then c do 70 j=1, ncv workl(ihb+j-1) = rnorm * abs( workl(ihb+j-1) ) 70 continue c else if (type .ne. 'REGULR' .and. rvec) then c c %-------------------------------------------------% c | * Determine Ritz estimates of the theta. | c | If RVEC = .true. then compute Ritz estimates | c | of the theta. | c | If RVEC = .false. then copy Ritz estimates | c | as computed by dsaupd . | c | * Determine Ritz estimates of the lambda. | c %-------------------------------------------------% c call dscal (ncv, bnorm2, workl(ihb), 1) if (type .eq. 'SHIFTI') then c do 80 k=1, ncv workl(ihb+k-1) = abs( workl(ihb+k-1) ) & / workl(iw+k-1)**2 80 continue c else if (type .eq. 'BUCKLE') then c do 90 k=1, ncv workl(ihb+k-1) = sigma * abs( workl(ihb+k-1) ) & / (workl(iw+k-1)-one )**2 90 continue c else if (type .eq. 'CAYLEY') then c do 100 k=1, ncv workl(ihb+k-1) = abs( workl(ihb+k-1) & / workl(iw+k-1)*(workl(iw+k-1)-one) ) 100 continue c end if c end if c if (type .ne. 'REGULR' .and. msglvl .gt. 1) then call dvout (logfil, nconv, d, ndigit, & '_seupd: Untransformed converged Ritz values') call dvout (logfil, nconv, workl(ihb), ndigit, & '_seupd: Ritz estimates of the untransformed Ritz values') else if (msglvl .gt. 1) then call dvout (logfil, nconv, d, ndigit, & '_seupd: Converged Ritz values') call dvout (logfil, nconv, workl(ihb), ndigit, & '_seupd: Associated Ritz estimates') end if c c %-------------------------------------------------% c | Ritz vector purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 3,4,5. See reference 7 | c %-------------------------------------------------% c if (rvec .and. (type .eq. 'SHIFTI' .or. type .eq. 'CAYLEY')) then c do 110 k=0, nconv-1 workl(iw+k) = workl(iq+k*ldq+ncv-1) & / workl(iw+k) 110 continue c else if (rvec .and. type .eq. 'BUCKLE') then c do 120 k=0, nconv-1 workl(iw+k) = workl(iq+k*ldq+ncv-1) & / (workl(iw+k)-one) 120 continue c end if c if (type .ne. 'REGULR') & call dger (n, nconv, one, resid, 1, workl(iw), 1, z, ldz) c 9000 continue c return c c %---------------% c | End of dseupd | c %---------------% c end arpack-akloeckner-07/SRC/dsesrt.f0000644000175000017500000001237006136210141016572 0ustar andreasandreasc----------------------------------------------------------------------- c\BeginDoc c c\Name: dsesrt c c\Description: c Sort the array X in the order specified by WHICH and optionally c apply the permutation to the columns of the matrix A. c c\Usage: c call dsesrt c ( WHICH, APPLY, N, X, NA, A, LDA) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> X is sorted into increasing order of magnitude. c 'SM' -> X is sorted into decreasing order of magnitude. c 'LA' -> X is sorted into increasing order of algebraic. c 'SA' -> X is sorted into decreasing order of algebraic. c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to A. c APPLY = .FALSE. -> do not apply the sorted order to A. c c N Integer. (INPUT) c Dimension of the array X. c c X Double precision array of length N. (INPUT/OUTPUT) c The array to be sorted. c c NA Integer. (INPUT) c Number of rows of the matrix A. c c A Double precision array of length NA by N. (INPUT/OUTPUT) c c LDA Integer. (INPUT) c Leading dimension of A. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines c dswap Level 1 BLAS that swaps the contents of two vectors. c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\Revision history: c 12/15/93: Version ' 2.1'. c Adapted from the sort routine in LANSO and c the ARPACK code dsortr c c\SCCS Information: @(#) c FILE: sesrt.F SID: 2.3 DATE OF SID: 4/19/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine dsesrt (which, apply, n, x, na, a, lda) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer lda, n, na c c %-----------------% c | Array Arguments | c %-----------------% c Double precision & x(0:n-1), a(lda, 0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Double precision & temp c c %----------------------% c | External Subroutines | c %----------------------% c external dswap c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'SA') then c c X is sorted into decreasing order of algebraic. c 10 continue if (igap .eq. 0) go to 9000 do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c if (x(j).lt.x(j+igap)) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 30 endif j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c X is sorted into decreasing order of magnitude. c 40 continue if (igap .eq. 0) go to 9000 do 60 i = igap, n-1 j = i-igap 50 continue c if (j.lt.0) go to 60 c if (abs(x(j)).lt.abs(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LA') then c c X is sorted into increasing order of algebraic. c 70 continue if (igap .eq. 0) go to 9000 do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (x(j).gt.x(j+igap)) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'LM') then c c X is sorted into increasing order of magnitude. c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (abs(x(j)).gt.abs(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp if (apply) call dswap( na, a(1, j), 1, a(1,j+igap), 1) else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 end if c 9000 continue return c c %---------------% c | End of dsesrt | c %---------------% c end arpack-akloeckner-07/SRC/cgetv0.f0000644000175000017500000003115010670622032016457 0ustar andreasandreasc\BeginDoc c c\Name: cgetv0 c c\Description: c Generate a random initial residual vector for the Arnoldi process. c Force the residual vector to be in the range of the operator OP. c c\Usage: c call cgetv0 c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, c IPNTR, WORKD, IERR ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to cgetv0. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B in the (generalized) c eigenvalue problem A*x = lambda*B*x. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c ITRY Integer. (INPUT) c ITRY counts the number of times that cgetv0 is called. c It should be set to 1 on the initial call to cgetv0. c c INITV Logical variable. (INPUT) c .TRUE. => the initial residual vector is given in RESID. c .FALSE. => generate a random initial residual vector. c c N Integer. (INPUT) c Dimension of the problem. c c J Integer. (INPUT) c Index of the residual vector to be generated, with respect to c the Arnoldi process. J > 1 in case of a "restart". c c V Complex N by J array. (INPUT) c The first J-1 columns of V contain the current Arnoldi basis c if this is a "restart". c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c RESID Complex array of length N. (INPUT/OUTPUT) c Initial residual vector to be generated. If RESID is c provided, force RESID into the range of the operator OP. c c RNORM Real scalar. (OUTPUT) c B-norm of the generated residual. c c IPNTR Integer array of length 3. (OUTPUT) c c WORKD Complex work array of length 2*N. (REVERSE COMMUNICATION). c On exit, WORK(1:N) = B*RESID to be used in SSAITR. c c IERR Integer. (OUTPUT) c = 0: Normal exit. c = -1: Cannot generate a nontrivial restarted residual vector c in the range of the operator OP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c arscnd ARPACK utility routine for timing. c cvout ARPACK utility routine that prints vectors. c clarnv LAPACK routine for generating a random vector. c cgemv Level 2 BLAS routine for matrix vector multiplication. c ccopy Level 1 BLAS that copies one vector to another. c cdotc Level 1 BLAS that computes the scalar product of two vectors. c scnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine cgetv0 & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, & ipntr, workd, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 logical initv integer ido, ierr, itry, j, ldv, n Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Complex & resid(n), v(ldv,j), workd(2*n) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rzero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), & rzero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical first, inits, orth integer idist, iseed(4), iter, msglvl, jj Real & rnorm0 Complex & cnorm save first, iseed, inits, iter, msglvl, orth, rnorm0 c c %----------------------% c | External Subroutines | c %----------------------% c external ccopy, cgemv, clarnv, cvout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Real & scnrm2, slapy2 Complex & cdotc external cdotc, scnrm2, slapy2 c c %-----------------% c | Data Statements | c %-----------------% c data inits /.true./ c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-----------------------------------% c | Initialize the seed of the LAPACK | c | random number generator | c %-----------------------------------% c if (inits) then iseed(1) = 1 iseed(2) = 3 iseed(3) = 5 iseed(4) = 7 inits = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mgetv0 c ierr = 0 iter = 0 first = .FALSE. orth = .FALSE. c c %-----------------------------------------------------% c | Possibly generate a random starting vector in RESID | c | Use a LAPACK random number generator used by the | c | matrix generation routines. | c | idist = 1: uniform (0,1) distribution; | c | idist = 2: uniform (-1,1) distribution; | c | idist = 3: normal (0,1) distribution; | c %-----------------------------------------------------% c if (.not.initv) then idist = 2 call clarnv (idist, iseed, n, resid) end if c c %----------------------------------------------------------% c | Force the starting vector into the range of OP to handle | c | the generalized problem when B is possibly (singular). | c %----------------------------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nopx = nopx + 1 ipntr(1) = 1 ipntr(2) = n + 1 call ccopy (n, resid, 1, workd, 1) ido = -1 go to 9000 end if end if c c %----------------------------------------% c | Back from computing B*(initial-vector) | c %----------------------------------------% c if (first) go to 20 c c %-----------------------------------------------% c | Back from computing B*(orthogonalized-vector) | c %-----------------------------------------------% c if (orth) go to 40 c call arscnd (t3) tmvopx = tmvopx + (t3 - t2) c c %------------------------------------------------------% c | Starting vector is now in the range of OP; r = OP*r; | c | Compute B-norm of starting vector. | c %------------------------------------------------------% c call arscnd (t2) first = .TRUE. if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, workd(n+1), 1, resid, 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd, 1) end if c 20 continue c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c first = .FALSE. if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd, 1) rnorm0 = sqrt(slapy2(real(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm0 = scnrm2(n, resid, 1) end if rnorm = rnorm0 c c %---------------------------------------------% c | Exit if this is the very first Arnoldi step | c %---------------------------------------------% c if (j .eq. 1) go to 50 c c %---------------------------------------------------------------- c | Otherwise need to B-orthogonalize the starting vector against | c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | c | This is the case where an invariant subspace is encountered | c | in the middle of the Arnoldi factorization. | c | | c | s = V^{T}*B*r; r = r - V*s; | c | | c | Stopping criteria used for iter. ref. is discussed in | c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | c %---------------------------------------------------------------% c orth = .TRUE. 30 continue c call cgemv ('C', n, j-1, one, v, ldv, workd, 1, & zero, workd(n+1), 1) call cgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, & one, resid, 1) c c %----------------------------------------------------------% c | Compute the B-norm of the orthogonalized starting vector | c %----------------------------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd, 1) end if c 40 continue c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd, 1) rnorm = sqrt(slapy2(real(cnorm),aimag(cnorm))) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) end if c c %--------------------------------------% c | Check for further orthogonalization. | c %--------------------------------------% c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm0, ndigit, & '_getv0: re-orthonalization ; rnorm0 is') call svout (logfil, 1, rnorm, ndigit, & '_getv0: re-orthonalization ; rnorm is') end if c if (rnorm .gt. 0.717*rnorm0) go to 50 c iter = iter + 1 if (iter .le. 1) then c c %-----------------------------------% c | Perform iterative refinement step | c %-----------------------------------% c rnorm0 = rnorm go to 30 else c c %------------------------------------% c | Iterative refinement step "failed" | c %------------------------------------% c do 45 jj = 1, n resid(jj) = zero 45 continue rnorm = rzero ierr = -1 end if c 50 continue c if (msglvl .gt. 0) then call svout (logfil, 1, rnorm, ndigit, & '_getv0: B-norm of initial / restarted starting vector') end if if (msglvl .gt. 2) then call cvout (logfil, n, resid, ndigit, & '_getv0: initial / restarted starting vector') end if ido = 99 c call arscnd (t1) tgetv0 = tgetv0 + (t1 - t0) c 9000 continue return c c %---------------% c | End of cgetv0 | c %---------------% c end arpack-akloeckner-07/SRC/cnaitr.f0000644000175000017500000007446710670622032016571 0ustar andreasandreasc\BeginDoc c c\Name: cnaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step nonsymmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in cnaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call cnaitr c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and do not need to be c recomputed in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. See cnaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current size of V and H. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c NB Integer. (INPUT) c Blocksize to be used in the recurrence. c Only work for NB = 1 right now. The goal is to have a c program that implement both the block and non-block method. c c RESID Complex array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Real scalar. (INPUT/OUTPUT) c B-norm of the starting residual on input. c B-norm of the updated residual r_{k+p} on output. c c V Complex N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex (K+NP) by (K+NP) array. (INPUT/OUTPUT) c H is used to store the generated upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On input, WORKD(1:N) = B*RESID and is used to save some c computation at the first step. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of the spanning invariant subspace of OP found. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c cgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c clanhs LAPACK routine that computes various norms of a matrix. c clascl LAPACK routine for careful scaling of a matrix. c slabad LAPACK routine for defining the underflow and overflow c limits. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c cgemv Level 2 BLAS routine for matrix vector multiplication. c caxpy Level 1 BLAS that computes a vector triad. c ccopy Level 1 BLAS that copies one vector to another . c cdotc Level 1 BLAS that computes the scalar product of two vectors. c cscal Level 1 BLAS that scales a vector. c csscal Level 1 BLAS that scales a complex vector by a real number. c scnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c ( At present tol is zero ) c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in cnaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c H(:,j) = w_{j}; c H(j,j-1) = rnorm c rnorm = || r_(j) || c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine cnaitr & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, nb, np Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Complex & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rone, rzero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), & rone = 1.0E+0, rzero = 0.0E+0) c c %--------------% c | Local Arrays | c %--------------% c Real & rtemp(2) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, & jj Real & ovfl, smlnum, tst1, ulp, unfl, betaj, & temp1, rnorm1, wnorm Complex & cnorm c save first, orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, & betaj, rnorm1, smlnum, ulp, unfl, wnorm c c %----------------------% c | External Subroutines | c %----------------------% c external caxpy, ccopy, cscal, csscal, cgemv, cgetv0, & slabad, cvout, cmout, ivout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Complex & cdotc Real & slamch, scnrm2, clanhs, slapy2 external cdotc, scnrm2, clanhs, slamch, slapy2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic aimag, real, max, sqrt c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------% c | Set machine-dependent constants for the | c | the splitting and deflation criterion. | c | If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine clahqr | c %-----------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = real(one / unfl) call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mcaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. j = k + 1 ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. when .... | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | cgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %-----------------------------% c | Else this is the first step | c %-----------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% 1000 continue c if (msglvl .gt. 1) then call ivout (logfil, 1, j, ndigit, & '_naitr: generating Arnoldi vector number') call svout (logfil, 1, rnorm, ndigit, & '_naitr: B-norm of the current residual is') end if c c %---------------------------------------------------% c | STEP 1: Check if the B norm of j-th residual | c | vector is zero. Equivalent to determine whether | c | an exact j-step Arnoldi factorization is present. | c %---------------------------------------------------% c betaj = rnorm if (rnorm .gt. rzero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: ****** RESTART AT STEP ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c betaj = rzero nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call cgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call arscnd (t1) tcaitr = tcaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call ccopy (n, resid, 1, v(1,j), 1) if ( rnorm .ge. unfl) then temp1 = rone / rnorm call csscal (n, temp1, v(1,j), 1) call csscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine clascl | c %-----------------------------------------% c call clascl ('General', i, i, rnorm, rone, & n, 1, v(1,j), n, infol) call clascl ('General', i, i, rnorm, rone, & n, 1, workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call arscnd (t2) call ccopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | c | if step3 = .true. | c %----------------------------------% c call arscnd (t3) tmvopx = tmvopx + (t3 - t2) step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call ccopy (n, workd(irj), 1, resid, 1) c c %---------------------------------------% c | STEP 4: Finish extending the Arnoldi | c | factorization to length j. | c %---------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd(ipj), 1) end if 60 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | c | if step4 = .true. | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd(ipj), 1) wnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then wnorm = scnrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1, & zero, h(1,j), 1) c c %--------------------------------------% c | Orthogonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call cgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c if (j .gt. 1) h(j,j-1) = cmplx(betaj, rzero) c call arscnd (t4) c orth1 = .true. c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd(ipj), 1) rnorm = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c | The following test determines whether the sine of the | c | angle between OP*x and the computed residual is less | c | than or equal to 0.717. | c %-----------------------------------------------------------% c if ( rnorm .gt. 0.717*wnorm ) go to 100 c iter = 0 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then rtemp(1) = wnorm rtemp(2) = rnorm call svout (logfil, 2, rtemp, ndigit, & '_naitr: re-orthogonalization; wnorm and rnorm are') call cvout (logfil, j, h(1,j), ndigit, & '_naitr: j-th column of H') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call cgemv ('C', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %---------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) | c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | c %---------------------------------------------% c call cgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) call caxpy (j, one, workd(irj), 1, h(1,j), 1) c orth2 = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then cnorm = cdotc (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt( slapy2(real(cnorm),aimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm1 = scnrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0 ) then call ivout (logfil, 1, j, ndigit, & '_naitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then rtemp(1) = rnorm rtemp(2) = rnorm1 call svout (logfil, 2, rtemp, ndigit, & '_naitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if ( rnorm1 .gt. 0.717*rnorm ) then c c %---------------------------------------% c | No need for further refinement. | c | The cosine of the angle between the | c | corrected residual vector and the old | c | residual vector is greater than 0.717 | c | In other words the corrected residual | c | and the old residual vector share an | c | angle of less than arcCOS(0.717) | c %---------------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = rzero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call arscnd (t5) titref = titref + (t5 - t4) c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call arscnd (t1) tcaitr = tcaitr + (t1 - t0) ido = 99 do 110 i = max(1,k), k+np-1 c c %--------------------------------------------% c | Check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine clahqr | c %--------------------------------------------% c tst1 = slapy2(real(h(i,i)),aimag(h(i,i))) & + slapy2(real(h(i+1,i+1)), aimag(h(i+1,i+1))) if( tst1.eq.real(zero) ) & tst1 = clanhs( '1', k+np, h, ldh, workd(n+1) ) if( slapy2(real(h(i+1,i)),aimag(h(i+1,i))) .le. & max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue c if (msglvl .gt. 2) then call cmout (logfil, k+np, k+np, h, ldh, ndigit, & '_naitr: Final upper Hessenberg matrix H of order K+NP') end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of cnaitr | c %---------------% c end arpack-akloeckner-07/SRC/cnapps.f0000644000175000017500000004220610670622032016557 0ustar andreasandreasc\BeginDoc c c\Name: cnapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP implicit shifts resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix which is the product of rotations c and reflections resulting from the NP bulge change sweeps. c The updated Arnoldi factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call cnapps c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, c WORKL, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. size of matrix A. c c KEV Integer. (INPUT/OUTPUT) c KEV+NP is the size of the input matrix H. c KEV is the size of the updated matrix HNEW. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFT Complex array of length NP. (INPUT) c The shifts to be applied. c c V Complex N by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, V contains the current KEV+NP Arnoldi vectors. c On OUTPUT, V contains the updated KEV Arnoldi vectors c in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, H contains the current KEV+NP by KEV+NP upper c Hessenberg matrix of the Arnoldi factorization. c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg c matrix in the KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Complex array of length N. (INPUT/OUTPUT) c On INPUT, RESID contains the the residual vector r_{k+p}. c On OUTPUT, RESID is the update residual vector rnew_{k} c in the first KEV locations. c c Q Complex KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations and reflections c during the bulge chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex work array of length (KEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c WORKD Complex work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c clacpy LAPACK matrix copy routine. c clanhs LAPACK routine that computes various norms of a matrix. c clartg LAPACK Givens rotation construction routine. c claset LAPACK matrix initialization routine. c slabad LAPACK routine for defining the underflow and overflow c limits. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c cgemv Level 2 BLAS routine for matrix vector multiplication. c caxpy Level 1 BLAS that computes a vector triad. c ccopy Level 1 BLAS that copies one vector to another. c cscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the sublocks of c the Hessenberg matrix H and not just to the submatrix that it c comes from. Deflation as in LAPACK routine clahqr (QR algorithm c for upper Hessenberg matrices ) is used. c Upon output, the subdiagonals of H are enforced to be non-negative c real numbers. c c\EndLib c c----------------------------------------------------------------------- c subroutine cnapps & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, & workl, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Complex & h(ldh,kev+np), resid(n), shift(np), & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rzero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), & rzero = 0.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, iend, istart, j, jj, kplusp, msglvl logical first Complex & cdum, f, g, h11, h21, r, s, sigma, t Real & c, ovfl, smlnum, ulp, unfl, tst1 save first, ovfl, smlnum, ulp, unfl c c %----------------------% c | External Subroutines | c %----------------------% c external caxpy, ccopy, cgemv, cscal, clacpy, clartg, & cvout, claset, slabad, cmout, arscnd, ivout c c %--------------------% c | External Functions | c %--------------------% c Real & clanhs, slamch, slapy2 external clanhs, slamch, slapy2 c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs, aimag, conjg, cmplx, max, min, real c c %---------------------% c | Statement Functions | c %---------------------% c Real & cabs1 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) ) c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------------% c | Set machine-dependent constants for the | c | stopping criterion. If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine clahqr | c %-----------------------------------------------% c unfl = slamch( 'safe minimum' ) ovfl = real(one / unfl) call slabad( unfl, ovfl ) ulp = slamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mcapps c kplusp = kev + np c c %--------------------------------------------% c | Initialize Q to the identity to accumulate | c | the rotations and reflections | c %--------------------------------------------% c call claset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------% c | Chase the bulge with the application of each | c | implicit shift. Each shift is applied to the | c | whole matrix including each block. | c %----------------------------------------------% c do 110 jj = 1, np sigma = shift(jj) c if (msglvl .gt. 2 ) then call ivout (logfil, 1, jj, ndigit, & '_napps: shift number.') call cvout (logfil, 1, sigma, ndigit, & '_napps: Value of the shift ') end if c istart = 1 20 continue c do 30 i = istart, kplusp-1 c c %----------------------------------------% c | Check for splitting and deflation. Use | c | a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine clahqr | c %----------------------------------------% c tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) ) if( tst1.eq.rzero ) & tst1 = clanhs( '1', kplusp-jj+1, h, ldh, workl ) if ( abs(real(h(i+1,i))) & .le. max(ulp*tst1, smlnum) ) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_napps: matrix splitting at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_napps: matrix splitting with shift number.') call cvout (logfil, 1, h(i+1,i), ndigit, & '_napps: off diagonal element.') end if iend = i h(i+1,i) = zero go to 40 end if 30 continue iend = kplusp 40 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, istart, ndigit, & '_napps: Start of current block ') call ivout (logfil, 1, iend, ndigit, & '_napps: End of current block ') end if c c %------------------------------------------------% c | No reason to apply a shift to block of order 1 | c | or if the current block starts after the point | c | of compression since we'll discard this stuff | c %------------------------------------------------% c if ( istart .eq. iend .or. istart .gt. kev) go to 100 c h11 = h(istart,istart) h21 = h(istart+1,istart) f = h11 - sigma g = h21 c do 80 i = istart, iend-1 c c %------------------------------------------------------% c | Construct the plane rotation G to zero out the bulge | c %------------------------------------------------------% c call clartg (f, g, c, s, r) if (i .gt. istart) then h(i,i-1) = r h(i+1,i-1) = zero end if c c %---------------------------------------------% c | Apply rotation to the left of H; H <- G'*H | c %---------------------------------------------% c do 50 j = i, kplusp t = c*h(i,j) + s*h(i+1,j) h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j) h(i,j) = t 50 continue c c %---------------------------------------------% c | Apply rotation to the right of H; H <- H*G | c %---------------------------------------------% c do 60 j = 1, min(i+2,iend) t = c*h(j,i) + conjg(s)*h(j,i+1) h(j,i+1) = -s*h(j,i) + c*h(j,i+1) h(j,i) = t 60 continue c c %-----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G' | c %-----------------------------------------------------% c do 70 j = 1, min(i+jj, kplusp) t = c*q(j,i) + conjg(s)*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = t 70 continue c c %---------------------------% c | Prepare for next rotation | c %---------------------------% c if (i .lt. iend-1) then f = h(i+1,i) g = h(i+2,i) end if 80 continue c c %-------------------------------% c | Finished applying the shift. | c %-------------------------------% c 100 continue c c %---------------------------------------------------------% c | Apply the same shift to the next block if there is any. | c %---------------------------------------------------------% c istart = iend + 1 if (iend .lt. kplusp) go to 20 c c %---------------------------------------------% c | Loop back to the top to get the next shift. | c %---------------------------------------------% c 110 continue c c %---------------------------------------------------% c | Perform a similarity transformation that makes | c | sure that the compressed H will have non-negative | c | real subdiagonal elements. | c %---------------------------------------------------% c do 120 j=1,kev if ( real( h(j+1,j) ) .lt. rzero .or. & aimag( h(j+1,j) ) .ne. rzero ) then t = h(j+1,j) / slapy2(real(h(j+1,j)),aimag(h(j+1,j))) call cscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) call cscal( min(j+2, kplusp), t, h(1,j+1), 1 ) call cscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) h(j+1,j) = cmplx( real( h(j+1,j) ), rzero ) end if 120 continue c do 130 i = 1, kev c c %--------------------------------------------% c | Final check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine clahqr. | c | Note: Since the subdiagonals of the | c | compressed H are nonnegative real numbers, | c | we take advantage of this. | c %--------------------------------------------% c tst1 = cabs1( h( i, i ) ) + cabs1( h( i+1, i+1 ) ) if( tst1 .eq. rzero ) & tst1 = clanhs( '1', kev, h, ldh, workl ) if( real( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 130 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is needed in the residual update since we | c | cannot GUARANTEE that the corresponding entry | c | of H would be zero as in exact arithmetic. | c %-------------------------------------------------% c if ( real( h(kev+1,kev) ) .gt. rzero ) & call cgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, & workd(n+1), 1) c c %----------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage of the upper Hessenberg structure of Q. | c %----------------------------------------------------------% c do 140 i = 1, kev call cgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call ccopy (n, workd, 1, v(1,kplusp-i+1), 1) 140 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call clacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) c c %--------------------------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | c %--------------------------------------------------------------% c if ( real( h(kev+1,kev) ) .gt. rzero ) & call ccopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kev+p}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call cscal (n, q(kplusp,kev), resid, 1) if ( real( h(kev+1,kev) ) .gt. rzero ) & call caxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call cvout (logfil, 1, q(kplusp,kev), ndigit, & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') call cvout (logfil, 1, h(kev+1,kev), ndigit, & '_napps: betak = e_{kev+1}^T*H*e_{kev}') call ivout (logfil, 1, kev, ndigit, & '_napps: Order of the final Hessenberg matrix ') if (msglvl .gt. 2) then call cmout (logfil, kev, kev, h, ldh, ndigit, & '_napps: updated Hessenberg matrix H for next iteration') end if c end if c 9000 continue call arscnd (t1) tcapps = tcapps + (t1 - t0) c return c c %---------------% c | End of cnapps | c %---------------% c end arpack-akloeckner-07/SRC/cnaup2.f0000644000175000017500000007103510670622032016465 0ustar andreasandreasc\BeginDoc c c\Name: cnaup2 c c\Description: c Intermediate level interface called by cnaupd. c c\Usage: c call cnaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in cnaupd. c MODE, ISHIFT, MXITER: see the definition of IPARAM in cnaupd. c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV since a leading block of the current c upper Hessenberg matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Complex N by (NEV+NP) array. (INPUT/OUTPUT) c The Arnoldi basis vectors are returned in the first NEV c columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex (NEV+NP) by (NEV+NP) array. (OUTPUT) c H is used to store the generated upper Hessenberg matrix c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Complex array of length NEV+NP. (OUTPUT) c RITZ(1:NEV) contains the computed Ritz values of OP. c c BOUNDS Complex array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to c the computed Ritz values. c c Q Complex (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex work array of length at least c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in shifts calculation, shifts c application and convergence checking. c c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Complex work array of length 3*N. (WORKSPACE) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in CNAUPD. c c RWORK Real work array of length NEV+NP ( WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. c NP returns the number of converged Ritz values. c = 2: No shifts could be applied. c = -8: Error return from LAPACK eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Arnoldi factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c cgetv0 ARPACK initial vector generation routine. c cnaitr ARPACK Arnoldi factorization routine. c cnapps ARPACK application of implicit shifts routine. c cneigh ARPACK compute Ritz values and error bounds routine. c cngets ARPACK reorder Ritz values and error bounds routine. c csortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c svout ARPACK utility routine that prints vectors. c slamch LAPACK routine that determines machine constants. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c ccopy Level 1 BLAS that copies one vector to another . c cdotc Level 1 BLAS that computes the scalar product of two vectors. c cswap Level 1 BLAS that swaps two vectors. c scnrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice Universitya c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine cnaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, & q, ldq, workl, ipntr, workd, rwork, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, & n, nev, np Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(13) Complex & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), & resid(n), ritz(nev+np), v(ldv,nev+np), & workd(3*n), workl( (nev+np)*(nev+np+3) ) Real & rwork(nev+np) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rzero parameter (one = (1.0E+0, 0.0E+0) , zero = (0.0E+0, 0.0E+0) , & rzero = 0.0E+0 ) c c %---------------% c | Local Scalars | c %---------------% c logical cnorm , getv0, initv , update, ushift integer ierr , iter , kplusp, msglvl, nconv, & nevbef, nev0 , np0 , nptemp, i , & j Complex & cmpnorm Real & rnorm , eps23, rtemp character wprime*2 c save cnorm, getv0, initv , update, ushift, & rnorm, iter , kplusp, msglvl, nconv , & nevbef, nev0 , np0 , eps23 c c c %-----------------------% c | Local array arguments | c %-----------------------% c integer kp(3) c c %----------------------% c | External Subroutines | c %----------------------% c external ccopy, cgetv0, cnaitr, cneigh, cngets, cnapps, & csortc, cswap, cmout, cvout, ivout, arscnd c c %--------------------% c | External functions | c %--------------------% c Complex & cdotc Real & scnrm2, slamch, slapy2 external cdotc, scnrm2, slamch, slapy2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic aimag, real , min, max c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c call arscnd (t0) c msglvl = mcaup2 c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvalues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev + np nconv = 0 iter = 0 c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0 ) c c %---------------------------------------% c | Set flags for computing the first NEV | c | steps of the Arnoldi factorization. | c %---------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call cgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. rzero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1100 end if getv0 = .false. ido = 0 end if c c %-----------------------------------% c | Back from reverse communication : | c | continue with update step | c %-----------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Arnoldi factorization | c %----------------------------------------------------------% c call cnaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N ARNOLDI I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Arnoldi | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_naup2: **** Start of major iteration number ****') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c | Adjust NP since NEV might have been updated by last call | c | to the shift application routine cnapps. | c %-----------------------------------------------------------% c np = kplusp - nev c if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_naup2: The length of the current Arnoldi factorization') call ivout (logfil, 1, np, ndigit, & '_naup2: Extend the Arnoldi factorization by') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c %-----------------------------------------------------------% c ido = 0 20 continue update = .true. c call cnaitr(ido, bmat, n, nev, np, mode, resid, rnorm, & v , ldv , h, ldh, ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call svout (logfil, 1, rnorm, ndigit, & '_naup2: Corresponding B-norm of the residual') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current upper Hessenberg matrix. | c %--------------------------------------------------------% c call cneigh (rnorm, kplusp, h, ldh, ritz, bounds, & q, ldq, workl, rwork, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | error bounds are in the last NEV loc. of RITZ, | c | and BOUNDS respectively. | c %---------------------------------------------------% c nev = nev0 np = np0 c c %--------------------------------------------------% c | Make a copy of Ritz values and the corresponding | c | Ritz estimates obtained from cneigh. | c %--------------------------------------------------% c call ccopy(kplusp,ritz,1,workl(kplusp**2+1),1) call ccopy(kplusp,bounds,1,workl(kplusp**2+kplusp+1),1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | bounds are in the last NEV loc. of RITZ | c | BOUNDS respectively. | c %---------------------------------------------------% c call cngets (ishift, which, nev, np, ritz, bounds) c c %------------------------------------------------------------% c | Convergence test: currently we use the following criteria. | c | The relative accuracy of a Ritz value is considered | c | acceptable if: | c | | c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). | c | | c %------------------------------------------------------------% c nconv = 0 c do 25 i = 1, nev rtemp = max( eps23, slapy2( real (ritz(np+i)), & aimag(ritz(np+i)) ) ) if ( slapy2(real (bounds(np+i)),aimag(bounds(np+i))) & .le. tol*rtemp ) then nconv = nconv + 1 end if 25 continue c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = nconv call ivout (logfil, 3, kp, ndigit, & '_naup2: NEV, NP, NCONV are') call cvout (logfil, kplusp, ritz, ndigit, & '_naup2: The eigenvalues of H') call cvout (logfil, kplusp, bounds, ndigit, & '_naup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. nev0) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c if (msglvl .gt. 4) then call cvout(logfil, kplusp, workl(kplusp**2+1), ndigit, & '_naup2: Eigenvalues computed by _neigh:') call cvout(logfil, kplusp, workl(kplusp**2+kplusp+1), & ndigit, & '_naup2: Ritz estimates computed by _neigh:') end if c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP | c %------------------------------------------------% c c %------------------------------------------% c | Use h( 3,1 ) as storage to communicate | c | rnorm to cneupd if needed | c %------------------------------------------% h(3,1) = cmplx(rnorm,rzero) c c %----------------------------------------------% c | Sort Ritz values so that converged Ritz | c | values appear within the first NEV locations | c | of ritz and bounds, and the most desired one | c | appears at the front. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LR') wprime = 'SR' if (which .eq. 'SR') wprime = 'LR' if (which .eq. 'LI') wprime = 'SI' if (which .eq. 'SI') wprime = 'LI' c call csortc(wprime, .true., kplusp, ritz, bounds) c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23, magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, nev0 rtemp = max( eps23, slapy2( real (ritz(j)), & aimag(ritz(j)) ) ) bounds(j) = bounds(j)/rtemp 35 continue c c %---------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | estimates. This will push all the converged ones | c | towards the front of ritz, bounds (in the case | c | when NCONV < NEV.) | c %---------------------------------------------------% c wprime = 'LM' call csortc(wprime, .true., nev0, bounds, ritz) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, nev0 rtemp = max( eps23, slapy2( real (ritz(j)), & aimag(ritz(j)) ) ) bounds(j) = bounds(j)*rtemp 40 continue c c %-----------------------------------------------% c | Sort the converged Ritz values again so that | c | the "threshold" value appears at the front of | c | ritz and bound. | c %-----------------------------------------------% c call csortc(which, .true., nconv, ritz, bounds) c if (msglvl .gt. 1) then call cvout (logfil, kplusp, ritz, ndigit, & '_naup2: Sorted eigenvalues') call cvout (logfil, kplusp, bounds, ndigit, & '_naup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. nev0) info = 2 c np = nconv go to 1100 c else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then c c %-------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the size | c | of NEV. | c %-------------------------------------------------% c nevbef = nev nev = nev + min(nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 3) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call cngets (ishift, which, nev, np, ritz, bounds) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_naup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_naup2: NEV and NP are') call cvout (logfil, nev, ritz(np+1), ndigit, & '_naup2: "wanted" Ritz values ') call cvout (logfil, nev, bounds(np+1), ndigit, & '_naup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-------------------------------------------------------% c | User specified shifts: pop back out to get the shifts | c | and return them in the first 2*NP locations of WORKL. | c %-------------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if 50 continue ushift = .false. c if ( ishift .ne. 1 ) then c c %----------------------------------% c | Move the NP shifts from WORKL to | c | RITZ, to free up WORKL | c | for non-exact shift case. | c %----------------------------------% c call ccopy (np, workl, 1, ritz, 1) end if c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_naup2: The number of shifts to apply ') call cvout (logfil, np, ritz, ndigit, & '_naup2: values of the shifts') if ( ishift .eq. 1 ) & call cvout (logfil, np, bounds, ndigit, & '_naup2: Ritz estimates of the shifts') end if c c %---------------------------------------------------------% c | Apply the NP implicit shifts by QR bulge chasing. | c | Each shift is applied to the whole upper Hessenberg | c | matrix H. | c | The first 2*N locations of WORKD are used as workspace. | c %---------------------------------------------------------% c call cnapps (n, nev, np, ritz, v, ldv, & h, ldh, resid, q, ldq, workl, workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to cnaitr. | c %---------------------------------------------% c cnorm = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call ccopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call ccopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then cmpnorm = cdotc (n, resid, 1, workd, 1) rnorm = sqrt(slapy2(real (cmpnorm),aimag(cmpnorm))) else if (bmat .eq. 'I') then rnorm = scnrm2(n, resid, 1) end if cnorm = .false. c if (msglvl .gt. 2) then call svout (logfil, 1, rnorm, ndigit, & '_naup2: B-norm of residual for compressed factorization') call cmout (logfil, nev, nev, h, ldh, ndigit, & '_naup2: Compressed upper Hessenberg matrix H') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = nconv c 1200 continue ido = 99 c c %------------% c | Error Exit | c %------------% c call arscnd (t1) tcaup2 = t1 - t0 c 9000 continue c c %---------------% c | End of cnaup2 | c %---------------% c return end arpack-akloeckner-07/SRC/cnaupd.f0000644000175000017500000006615210670622032016553 0ustar andreasandreasc\BeginDoc c c\Name: cnaupd c c\Description: c Reverse communication interface for the Implicitly Restarted Arnoldi c iteration. This is intended to be used to find a few eigenpairs of a c complex linear operator OP with respect to a semi-inner product defined c by a hermitian positive semi-definite real matrix B. B may be the identity c matrix. NOTE: if both OP and B are real, then ssaupd or snaupd should c be used. c c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c cnaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x. c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, M hermitian positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: A*x = lambda*M*x, M hermitian semi-definite c ===> OP = inv[A - sigma*M]*M and B = M. c ===> shift-and-invert mode c If OP*x = amu*x, then lambda = sigma + 1/amu. c c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call cnaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to cnaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c cnaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = M * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute and return the shifts in the first c NP locations of WORKL. c IDO = 99: done c ------------------------------------------------------------- c After the initialization phase, when the routine is used in c the "shift-and-invert" mode, the vector M * X is already c available and does not need to be recomputed in forming OP*X. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. c c TOL Real scalar. (INPUT) c Stopping criteria: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = slamch('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine slamch). c c RESID Complex array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 1 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. (See remark 4 below.) c c V Complex array N by NCV. (OUTPUT) c Contains the final set of Arnoldi basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to filter out c the components of the unwanted eigenvector. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are to be provided by the user via c reverse communication. The NCV eigenvalues of c the Hessenberg matrix H are returned in the part c of WORKL array corresponding to RITZ. c ISHIFT = 1: exact shifts with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration from the beginning c after updating the starting vector with a linear c combination of Ritz vectors associated with the c "wanted" eigenvalues. c ISHIFT = 2: other choice of internal shift to be defined. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3; See under \Description of cnaupd for the c four modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), _naupd returns NP, the number c of shifts the user is to provide. 0 < NP < NCV-NEV. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 14. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by NCV upper Hessenberg c matrix H in WORKL. c IPNTR(6): pointer to the ritz value array RITZ c IPNTR(7): pointer to the (projected) ritz vector array Q c IPNTR(8): pointer to the error BOUNDS array in WORKL. c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. c c Note: IPNTR(9:13) is only referenced by cneupd. See Remark 2 below. c c IPNTR(9): pointer to the NCV RITZ values of the c original system. c IPNTR(10): Not Used c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c cneupd if RVEC = .TRUE. See Remark 2 below. c c ------------------------------------------------------------- c c WORKD Complex work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note below. c c WORKL Complex work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 5*NCV. c c RWORK Real work array of length NCV (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 1 and less than or equal to N. c = -4: The maximum number of Arnoldi update iteration c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation; c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: IPARAM(1) must be equal to 0 or 1. c = -9999: Could not build an Arnoldi factorization. c User input error highly likely. Please c check actual array dimensions and layout. c IPARAM(5) returns the size of the current Arnoldi c factorization. c c\Remarks c 1. The computed Ritz values are approximate eigenvalues of OP. The c selection of WHICH should be made with this in mind when using c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will c compute the NEV eigenvalues of the original problem that are c closest to the shift SIGMA . After convergence, approximate eigenvalues c of the original problem may be obtained with the ARPACK subroutine cneupd. c c 2. If a basis for the invariant subspace corresponding to the converged Ritz c values is needed, the user must call cneupd immediately following c completion of cnaupd. This is new starting with release 2 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1. c However, it is recommended that NCV .ge. 2*NEV. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c See Chapter 8 of Reference 2 for further information. c c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) complex shifts in locations c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP). c Eigenvalues of the current upper Hessenberg matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered c according to the order defined by WHICH. The associated Ritz estimates c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , c WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c Complex resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c decompose d1(n), d2(n,ncv) c align resid(i) with d1(i) c align v(i,j) with d2(i,j) c align workd(i) with d1(i) range (1:n) c align workd(i) with d1(i-n) range (n+1:2*n) c align workd(i) with d1(i-2*n) range (2*n+1:3*n) c distribute d1(block), d2(block,:) c replicated workl(lworkl) c c Cray MPP syntax: c =============== c Complex resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) c shared resid(block), v(block,:), workd(block,:) c replicated workl(lworkl) c c CM2/CM5 syntax: c ============== c c----------------------------------------------------------------------- c c include 'ex-nonsym.doc' c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for c Real Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c cnaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c cstatn ARPACK routine that initializes the timing variables. c ivout ARPACK utility routine that prints integers. c cvout ARPACK utility routine that prints vectors. c arscnd ARPACK utility routine for timing. c slamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naupd.F SID: 2.9 DATE OF SID: 07/21/02 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine cnaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, rwork, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) Complex & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) Real & rwork(ncv) c c %------------% c | Parameters | c %------------% c Complex & one, zero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritz, j save bounds, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritz c c %----------------------% c | External Subroutines | c %----------------------% c external cnaup2, cvout, ivout, arscnd, cstatn c c %--------------------% c | External Functions | c %--------------------% c Real & slamch external slamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call cstatn call arscnd (t0) msglvl = mcaupd c c %----------------% c | Error checking | c %----------------% c ierr = 0 ishift = iparam(1) c levec = iparam(2) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 else if (mxiter .le. 0) then ierr = -4 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 5*ncv) then ierr = -7 else if (mode .lt. 1 .or. mode .gt. 3) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. 0.0E+0 ) tol = slamch('EpsMach') if (ishift .ne. 0 .and. & ishift .ne. 1 .and. & ishift .ne. 2) ishift = 1 c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, 3*ncv**2 + 5*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | c | The final workspace is needed by subroutine cneigh called | c | by cnaup2. Subroutine cneigh calls LAPACK routines for | c | calculating eigenvalues and the last row of the eigenvector | c | matrix. | c %-------------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritz = ih + ldh*ncv bounds = ritz + ncv iq = bounds + ncv iw = iq + ldq*ncv next = iw + ncv**2 + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritz ipntr(7) = iq ipntr(8) = bounds ipntr(14) = iw end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Arnoldi Iteration. | c %-------------------------------------------------------% c call cnaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), & workl(bounds), workl(iq), ldq, workl(iw), & ipntr, workd, rwork, info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within cnaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_naupd: Number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_naupd: Number of wanted "converged" Ritz values') call cvout (logfil, np, workl(ritz), ndigit, & '_naupd: The final Ritz values') call cvout (logfil, np, workl(bounds), ndigit, & '_naupd: Associated Ritz estimates') end if c call arscnd (t1) tcaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref, & tgetv0, tceigh, tcgets, tcapps, tcconv, trvec 1000 format (//, & 5x, '=============================================',/ & 5x, '= Complex implicit Arnoldi update code =',/ & 5x, '= Version Number: ', ' 2.3', 21x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ & 5x, '=============================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '=============================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in naup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6,/ & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) end if c 9000 continue c return c c %---------------% c | End of cnaupd | c %---------------% c end arpack-akloeckner-07/SRC/cneigh.f0000644000175000017500000001771110670622032016533 0ustar andreasandreasc\BeginDoc c c\Name: cneigh c c\Description: c Compute the eigenvalues of the current upper Hessenberg matrix c and the corresponding Ritz estimates given the current residual norm. c c\Usage: c call cneigh c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR ) c c\Arguments c RNORM Real scalar. (INPUT) c Residual norm corresponding to the current upper Hessenberg c matrix H. c c N Integer. (INPUT) c Size of the matrix H. c c H Complex N by N array. (INPUT) c H contains the current upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Complex array of length N. (OUTPUT) c On output, RITZ(1:N) contains the eigenvalues of H. c c BOUNDS Complex array of length N. (OUTPUT) c On output, BOUNDS contains the Ritz estimates associated with c the eigenvalues held in RITZ. This is equal to RNORM c times the last components of the eigenvectors corresponding c to the eigenvalues in RITZ. c c Q Complex N by N array. (WORKSPACE) c Workspace needed to store the eigenvectors of H. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex work array of length N**2 + 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. This is needed to keep the full Schur form c of H and also in the calculation of the eigenvectors of H. c c RWORK Real work array of length N (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c IERR Integer. (OUTPUT) c Error exit flag from clahqr or ctrevc. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\Routines called: c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c svout ARPACK utility routine that prints vectors. c clacpy LAPACK matrix copy routine. c clahqr LAPACK routine to compute the Schur form of an c upper Hessenberg matrix. c claset LAPACK matrix initialization routine. c ctrevc LAPACK routine to compute the eigenvectors of a matrix c in upper triangular form c ccopy Level 1 BLAS that copies one vector to another. c csscal Level 1 BLAS that scales a complex vector by a real number. c scnrm2 Level 1 BLAS that computes the norm of a vector. c c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine cneigh (rnorm, n, h, ldh, ritz, bounds, & q, ldq, workl, rwork, ierr) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, n, ldh, ldq Real & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Complex & bounds(n), h(ldh,n), q(ldq,n), ritz(n), & workl(n*(n+3)) Real & rwork(n) c c %------------% c | Parameters | c %------------% c Complex & one, zero Real & rone parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0), & rone = 1.0E+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical select(1) integer j, msglvl Complex & vl(1) Real & temp c c %----------------------% c | External Subroutines | c %----------------------% c external clacpy, clahqr, ctrevc, ccopy, & csscal, cmout, cvout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Real & scnrm2 external scnrm2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mceigh c if (msglvl .gt. 2) then call cmout (logfil, n, n, h, ldh, ndigit, & '_neigh: Entering upper Hessenberg matrix H ') end if c c %----------------------------------------------------------% c | 1. Compute the eigenvalues, the last components of the | c | corresponding Schur vectors and the full Schur form T | c | of the current upper Hessenberg matrix H. | c | clahqr returns the full Schur form of H | c | in WORKL(1:N**2), and the Schur vectors in q. | c %----------------------------------------------------------% c call clacpy ('All', n, n, h, ldh, workl, n) call claset ('All', n, n, zero, one, q, ldq) call clahqr (.true., .true., n, 1, n, workl, ldh, ritz, & 1, n, q, ldq, ierr) if (ierr .ne. 0) go to 9000 c call ccopy (n, q(n-1,1), ldq, bounds, 1) if (msglvl .gt. 1) then call cvout (logfil, n, bounds, ndigit, & '_neigh: last row of the Schur matrix for H') end if c c %----------------------------------------------------------% c | 2. Compute the eigenvectors of the full Schur form T and | c | apply the Schur vectors to get the corresponding | c | eigenvectors. | c %----------------------------------------------------------% c call ctrevc ('Right', 'Back', select, n, workl, n, vl, n, q, & ldq, n, n, workl(n*n+1), rwork, ierr) c if (ierr .ne. 0) go to 9000 c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | ctrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; here the magnitude of a complex | c | number (x,y) is taken to be |x| + |y|. | c %------------------------------------------------% c do 10 j=1, n temp = scnrm2( n, q(1,j), 1 ) call csscal ( n, rone / temp, q(1,j), 1 ) 10 continue c if (msglvl .gt. 1) then call ccopy(n, q(n,1), ldq, workl, 1) call cvout (logfil, n, workl, ndigit, & '_neigh: Last row of the eigenvector matrix for H') end if c c %----------------------------% c | Compute the Ritz estimates | c %----------------------------% c call ccopy(n, q(n,1), n, bounds, 1) call csscal(n, rnorm, bounds, 1) c if (msglvl .gt. 2) then call cvout (logfil, n, ritz, ndigit, & '_neigh: The eigenvalues of H') call cvout (logfil, n, bounds, ndigit, & '_neigh: Ritz estimates for the eigenvalues of H') end if c call arscnd(t1) tceigh = tceigh + (t1 - t0) c 9000 continue return c c %---------------% c | End of cneigh | c %---------------% c end arpack-akloeckner-07/SRC/cneupd.f0000644000175000017500000010375607526640520016571 0ustar andreasandreasc\BeginDoc c c\Name: cneupd c c\Description: c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are derived from approximate eigenvalues and eigenvectors of c of the linear operator OP prescribed by the MODE selection in the c call to CNAUPD. CNAUPD must be called before this routine is called. c These approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c The definition of OP as well as other terms and the relation of computed c Ritz values and vectors of OP with respect to the given problem c A*z = lambda*B*z may be found in the header of CNAUPD. For a brief c description, see definitions of IPARAM(7), MODE and WHICH in the c documentation of CNAUPD. c c\Usage: c call cneupd c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT, c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, c WORKL, LWORKL, RWORK, INFO ) c c\Arguments: c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT need not be initialized c but it is used as internal workspace. c c D Complex array of dimension NEV+1. (OUTPUT) c On exit, D contains the Ritz approximations c to the eigenvalues lambda for A*z = lambda*B*z. c c Z Complex N by NEV array (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represents approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by CNAUPD. In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ) is required. c In any case, LDZ .ge. 1 is required. c c SIGMA Complex (INPUT) c If IPARAM(7) = 3 then SIGMA represents the shift. c Not referenced if IPARAM(7) = 1 or 2. c c WORKEV Complex work array of dimension 2*NCV. (WORKSPACE) c c **** The remaining arguments MUST be the same as for the **** c **** call to CNAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, RWORK, INFO c c must be passed directly to CNEUPD following the last call c to CNAUPD. These arguments MUST NOT BE MODIFIED between c the the last call to CNAUPD and the call to CNEUPD. c c Three of these parameters (V, WORKL and INFO) are also output parameters: c c V Complex N by NCV array. (INPUT/OUTPUT) c c Upon INPUT: the NCV columns of V contain the Arnoldi basis c vectors for OP as constructed by CNAUPD . c c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the c Arnoldi basis held by V has been overwritten by the desired c Ritz vectors. If a separate array Z has been passed then c the first NCONV=IPARAM(5) columns of V will contain approximate c Schur vectors that span the desired invariant subspace. c c WORKL Real work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:ncv*ncv+2*ncv) contains information obtained in c cnaupd. They are not changed by cneupd. c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the c untransformed Ritz values, the untransformed error estimates of c the Ritz values, the upper triangular matrix for H, and the c associated matrix representation of the invariant subspace for H. c c Note: IPNTR(9:13) contains the pointer into WORKL for addresses c of the above information computed by cneupd. c ------------------------------------------------------------- c IPNTR(9): pointer to the NCV RITZ values of the c original system. c IPNTR(10): Not used c IPNTR(11): pointer to the NCV corresponding error estimates. c IPNTR(12): pointer to the NCV by NCV upper triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c cneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c = 0: Normal exit. c c = 1: The Schur form computed by LAPACK routine csheqr c could not be reordered by LAPACK routine ctrsen. c Re-enter subroutine cneupd with IPARAM(5)=NCV and c increase the size of the array D to have c dimension at least dimension NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors if this error c occurs. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 1 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation. c This should never happened. c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine ctrevc. c = -10: IPARAM(7) must be 1,2,3 c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: CNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: CNEUPD got a different count of the number of converged c Ritz values than CNAUPD got. This indicates the user c probably made an error in passing data from CNAUPD to c CNEUPD or that the data was modified before entering c CNEUPD c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen, c "How to Implement the Spectral Transformation", Math Comp., c Vol. 48, No. 178, April, 1987 pp. 664-673. c c\Routines called: c ivout ARPACK utility routine that prints integers. c cmout ARPACK utility routine that prints matrices c cvout ARPACK utility routine that prints vectors. c cgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c clacpy LAPACK matrix copy routine. c clahqr LAPACK routine that computes the Schur form of a c upper Hessenberg matrix. c claset LAPACK matrix initialization routine. c ctrevc LAPACK routine to compute the eigenvectors of a matrix c in upper triangular form. c ctrsen LAPACK routine that re-orders the Schur form. c cunm2r LAPACK routine that applies an orthogonal matrix in c factored form. c slamch LAPACK routine that determines machine constants. c ctrmm Level 3 BLAS matrix times an upper triangular matrix. c cgeru Level 2 BLAS rank one update to a matrix. c ccopy Level 1 BLAS that copies one vector to another . c cscal Level 1 BLAS that scales a vector. c csscal Level 1 BLAS that scales a complex vector by a real number. c scnrm2 Level 1 BLAS that computes the norm of a complex vector. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .true. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I c are approximately satisfied. c Here T is the leading submatrix of order IPARAM(5) of the c upper triangular matrix stored workl(ipntr(12)). c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neupd.F SID: 2.8 DATE OF SID: 07/21/02 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine cneupd(rvec , howmny, select, d , & z , ldz , sigma , workev, & bmat , n , which , nev , & tol , resid , ncv , v , & ldv , iparam, ipntr , workd , & workl, lworkl, rwork , info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Complex & sigma Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) logical select(ncv) Real & rwork(ncv) Complex & d(nev) , resid(n) , v(ldv,ncv), & z(ldz, nev), & workd(3*n) , workl(lworkl), workev(2*ncv) c c %------------% c | Parameters | c %------------% c Complex & one, zero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds, ierr , ih , ihbds, iheig , nconv , & invsub, iuptri, iwev , j , ldh , ldq , & mode , msglvl, ritz , wr , k , irz , & ibd , outncv, iq , np , numcnv, jj , & ishift Complex & rnorm, temp, vl(1) Real & conds, sep, rtemp, eps23 logical reord c c %----------------------% c | External Subroutines | c %----------------------% c external ccopy , cgeru, cgeqr2, clacpy, cmout, & cunm2r, ctrmm, cvout, ivout, & clahqr c c %--------------------% c | External Functions | c %--------------------% c Real & scnrm2, slamch, slapy2 external scnrm2, slamch, slapy2 c Complex & cdotc external cdotc c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mceupd mode = iparam(7) nconv = iparam(5) info = 0 c c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = slamch('Epsilon-Machine') eps23 = eps23**(2.0E+0 / 3.0E+0) c c %-------------------------------% c | Quick return | c | Check for incompatible input | c %-------------------------------% c ierr = 0 c if (nconv .le. 0) then ierr = -14 else if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 4*ncv) then ierr = -7 else if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) then ierr = -13 else if (howmny .eq. 'S' ) then ierr = -12 end if c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 ) then type = 'SHIFTI' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %--------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, WORKEV, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | c %--------------------------------------------------------% c c %-----------------------------------------------------------% c | The following is used and set by CNEUPD. | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | c | Ritz values. | c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | c | error bounds of | c | the Ritz values | c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | c | triangular matrix | c | for H. | c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | c | associated matrix | c | representation of | c | the invariant | c | subspace for H. | c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | c %-----------------------------------------------------------% c ih = ipntr(5) ritz = ipntr(6) iq = ipntr(7) bounds = ipntr(8) ldh = ncv ldq = ncv iheig = bounds + ldh ihbds = iheig + ldh iuptri = ihbds + ldh invsub = iuptri + ldh*ncv ipntr(9) = iheig ipntr(11) = ihbds ipntr(12) = iuptri ipntr(13) = invsub wr = 1 iwev = wr + ncv c c %-----------------------------------------% c | irz points to the Ritz values computed | c | by _neigh before exiting _naup2. | c | ibd points to the Ritz estimates | c | computed by _neigh before exiting | c | _naup2. | c %-----------------------------------------% c irz = ipntr(14) + ncv*ncv ibd = irz + ncv c c %------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c %------------------------------------% c rnorm = workl(ih+2) workl(ih+2) = zero c if (msglvl .gt. 2) then call cvout(logfil, ncv, workl(irz), ndigit, & '_neupd: Ritz values passed in from _NAUPD.') call cvout(logfil, ncv, workl(ibd), ndigit, & '_neupd: Ritz estimates passed in from _NAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(ibd) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call cngets(ishift, which , nev , & np , workl(irz), workl(bounds)) c if (msglvl .gt. 2) then call cvout (logfil, ncv, workl(irz), ndigit, & '_neupd: Ritz values after calling _NGETS.') call cvout (logfil, ncv, workl(bounds), ndigit, & '_neupd: Ritz value indices after calling _NGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv rtemp = max(eps23, & slapy2 ( real(workl(irz+ncv-j)), & aimag(workl(irz+ncv-j)) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & slapy2( real(workl(ibd+jj-1)), & aimag(workl(ibd+jj-1)) ) & .le. tol*rtemp) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by dnaupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the dnaupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_neupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_neupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -15 go to 9000 end if c c %-------------------------------------------------------% c | Call LAPACK routine clahqr to compute the Schur form | c | of the upper Hessenberg matrix returned by CNAUPD. | c | Make a copy of the upper Hessenberg matrix. | c | Initialize the Schur vector matrix Q to the identity. | c %-------------------------------------------------------% c call ccopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) call claset('All', ncv, ncv , & zero , one, workl(invsub), & ldq) call clahqr(.true., .true. , ncv , & 1 , ncv , workl(iuptri), & ldh , workl(iheig) , 1 , & ncv , workl(invsub), ldq , & ierr) call ccopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call cvout (logfil, ncv, workl(iheig), ndigit, & '_neupd: Eigenvalues of H') call cvout (logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the Schur vector matrix') if (msglvl .gt. 3) then call cmout (logfil , ncv, ncv , & workl(iuptri), ldh, ndigit, & '_neupd: The upper triangular matrix ') end if end if c if (reord) then c c %-----------------------------------------------% c | Reorder the computed upper triangular matrix. | c %-----------------------------------------------% c call ctrsen('None' , 'V' , select , & ncv , workl(iuptri), ldh , & workl(invsub), ldq , workl(iheig), & nconv , conds , sep , & workev , ncv , ierr) c if (ierr .eq. 1) then info = 1 go to 9000 end if c if (msglvl .gt. 2) then call cvout (logfil, ncv, workl(iheig), ndigit, & '_neupd: Eigenvalues of H--reordered') if (msglvl .gt. 3) then call cmout(logfil , ncv, ncv , & workl(iuptri), ldq, ndigit, & '_neupd: Triangular matrix after re-ordering') end if end if c end if c c %---------------------------------------------% c | Copy the last row of the Schur basis matrix | c | to workl(ihbds). This vector will be used | c | to compute the Ritz estimates of converged | c | Ritz values. | c %---------------------------------------------% c call ccopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c c %--------------------------------------------% c | Place the computed eigenvalues of H into D | c | if a spectral transformation was not used. | c %--------------------------------------------% c if (type .eq. 'REGULR') then call ccopy(nconv, workl(iheig), 1, d, 1) end if c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(invsub,ldq). | c %----------------------------------------------------------% c call cgeqr2(ncv , nconv , workl(invsub), & ldq , workev, workev(ncv+1), & ierr) c c %--------------------------------------------------------% c | * Postmultiply V by Q using cunm2r. | c | * Copy the first NCONV columns of VQ into Z. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(iheig). The first NCONV | c | columns of V are now approximate Schur vectors | c | associated with the upper triangular matrix of order | c | NCONV in workl(iuptri). | c %--------------------------------------------------------% c call cunm2r('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , v , & ldv , workd(n+1) , ierr) call clacpy('All', n, nconv, v, ldv, z, ldz) c do 20 j=1, nconv c c %---------------------------------------------------% c | Perform both a column and row scaling if the | c | diagonal element of workl(invsub,ldq) is negative | c | I'm lazy and don't take advantage of the upper | c | triangular form of workl(iuptri,ldq). | c | Note that since Q is orthogonal, R is a diagonal | c | matrix consisting of plus or minus ones. | c %---------------------------------------------------% c if ( real( workl(invsub+(j-1)*ldq+j-1) ) .lt. & real(zero) ) then call cscal(nconv, -one, workl(iuptri+j-1), ldq) call cscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) end if c 20 continue c if (howmny .eq. 'A') then c c %--------------------------------------------% c | Compute the NCONV wanted eigenvectors of T | c | located in workl(iuptri,ldq). | c %--------------------------------------------% c do 30 j=1, ncv if (j .le. nconv) then select(j) = .true. else select(j) = .false. end if 30 continue c call ctrevc('Right', 'Select' , select , & ncv , workl(iuptri), ldq , & vl , 1 , workl(invsub), & ldq , ncv , outncv , & workev , rwork , ierr) c if (ierr .ne. 0) then info = -9 go to 9000 end if c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | ctrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1. | c %------------------------------------------------% c do 40 j=1, nconv rtemp = scnrm2(ncv, workl(invsub+(j-1)*ldq), 1) rtemp = real(one) / rtemp call csscal ( ncv, rtemp, & workl(invsub+(j-1)*ldq), 1 ) c c %------------------------------------------% c | Ritz estimates can be obtained by taking | c | the inner product of the last row of the | c | Schur basis of H with eigenvectors of T. | c | Note that the eigenvector matrix of T is | c | upper triangular, thus the length of the | c | inner product can be set to j. | c %------------------------------------------% c workev(j) = cdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c if (msglvl .gt. 2) then call ccopy(nconv, workl(invsub+ncv-1), ldq, & workl(ihbds), 1) call cvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Last row of the eigenvector matrix for T') if (msglvl .gt. 3) then call cmout(logfil , ncv, ncv , & workl(invsub), ldq, ndigit, & '_neupd: The eigenvector matrix for T') end if end if c c %---------------------------------------% c | Copy Ritz estimates into workl(ihbds) | c %---------------------------------------% c call ccopy(nconv, workev, 1, workl(ihbds), 1) c c %----------------------------------------------% c | The eigenvector matrix Q of T is triangular. | c | Form Z*Q. | c %----------------------------------------------% c call ctrmm('Right' , 'Upper' , 'No transpose', & 'Non-unit', n , nconv , & one , workl(invsub), ldq , & z , ldz) end if c else c c %--------------------------------------------------% c | An approximate invariant subspace is not needed. | c | Place the Ritz values computed CNAUPD into D. | c %--------------------------------------------------% c call ccopy(nconv, workl(ritz), 1, d, 1) call ccopy(nconv, workl(ritz), 1, workl(iheig), 1) call ccopy(nconv, workl(bounds), 1, workl(ihbds), 1) c end if c c %------------------------------------------------% c | Transform the Ritz values and possibly vectors | c | and corresponding error bounds of OP to those | c | of A*x = lambda*B*x. | c %------------------------------------------------% c if (type .eq. 'REGULR') then c if (rvec) & call cscal(ncv, rnorm, workl(ihbds), 1) c else c c %---------------------------------------% c | A spectral transformation was used. | c | * Determine the Ritz estimates of the | c | Ritz values in the original system. | c %---------------------------------------% c if (rvec) & call cscal(ncv, rnorm, workl(ihbds), 1) c do 50 k=1, ncv temp = workl(iheig+k-1) workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp 50 continue c end if c c %-----------------------------------------------------------% c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c %-----------------------------------------------------------% c if (type .eq. 'SHIFTI') then do 60 k=1, nconv d(k) = one / workl(iheig+k-1) + sigma 60 continue end if c if (type .ne. 'REGULR' .and. msglvl .gt. 1) then call cvout (logfil, nconv, d, ndigit, & '_neupd: Untransformed Ritz values.') call cvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Ritz estimates of the untransformed Ritz values.') else if ( msglvl .gt. 1) then call cvout (logfil, nconv, d, ndigit, & '_neupd: Converged Ritz values.') call cvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Associated Ritz estimates.') end if c c %-------------------------------------------------% c | Eigenvector Purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 3. See reference 3. | c %-------------------------------------------------% c if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then c c %------------------------------------------------% c | Purify the computed Ritz vectors by adding a | c | little bit of the residual vector: | c | T | c | resid(:)*( e s ) / theta | c | NCV | c | where H s = s theta. | c %------------------------------------------------% c do 100 j=1, nconv if (workl(iheig+j-1) .ne. zero) then workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / & workl(iheig+j-1) endif 100 continue c %---------------------------------------% c | Perform a rank one update to Z and | c | purify all the Ritz vectors together. | c %---------------------------------------% c call cgeru (n, nconv, one, resid, 1, workev, 1, z, ldz) c end if c 9000 continue c return c c %---------------% c | End of cneupd| c %---------------% c end arpack-akloeckner-07/SRC/cngets.f0000644000175000017500000001267310670622032016563 0ustar andreasandreasc\BeginDoc c c\Name: cngets c c\Description: c Given the eigenvalues of the upper Hessenberg matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: call this even in the case of user specified shifts in order c to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call cngets c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> want the KEV eigenvalues of largest magnitude. c 'SM' -> want the KEV eigenvalues of smallest magnitude. c 'LR' -> want the KEV eigenvalues of largest REAL part. c 'SR' -> want the KEV eigenvalues of smallest REAL part. c 'LI' -> want the KEV eigenvalues of largest imaginary part. c 'SI' -> want the KEV eigenvalues of smallest imaginary part. c c KEV Integer. (INPUT) c The number of desired eigenvalues. c c NP Integer. (INPUT) c The number of shifts to compute. c c RITZ Complex array of length KEV+NP. (INPUT/OUTPUT) c On INPUT, RITZ contains the the eigenvalues of H. c On OUTPUT, RITZ are sorted so that the unwanted c eigenvalues are in the first NP locations and the wanted c portion is in the last KEV locations. When exact shifts are c selected, the unwanted part corresponds to the shifts to c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues c are further sorted so that the ones with largest Ritz values c are first. c c BOUNDS Complex array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex c c\Routines called: c csortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c cvout ARPACK utility routine that prints vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. This routine does not keep complex conjugate pairs of c eigenvalues together. c c\EndLib c c----------------------------------------------------------------------- c subroutine cngets ( ishift, which, kev, np, ritz, bounds) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Complex & bounds(kev+np), ritz(kev+np) c c %------------% c | Parameters | c %------------% c Complex & one, zero parameter (one = (1.0E+0, 0.0E+0), zero = (0.0E+0, 0.0E+0)) c c %---------------% c | Local Scalars | c %---------------% c integer msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external cvout, csortc, arscnd c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mcgets c call csortc (which, .true., kev+np, ritz, bounds) c if ( ishift .eq. 1 ) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first | c | This will tend to minimize the effects of the | c | forward instability of the iteration when the shifts | c | are applied in subroutine cnapps. | c | Be careful and use 'SM' since we want to sort BOUNDS! | c %-------------------------------------------------------% c call csortc ( 'SM', .true., np, bounds, ritz ) c end if c call arscnd (t1) tcgets = tcgets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') call ivout (logfil, 1, np, ndigit, '_ngets: NP is') call cvout (logfil, kev+np, ritz, ndigit, & '_ngets: Eigenvalues of current H matrix ') call cvout (logfil, kev+np, bounds, ndigit, & '_ngets: Ritz estimates of the current KEV+NP Ritz values') end if c return c c %---------------% c | End of cngets | c %---------------% c end arpack-akloeckner-07/SRC/csortc.f0000644000175000017500000001757506136215714016612 0ustar andreasandreasc\BeginDoc c c\Name: csortc c c\Description: c Sorts the Complex array in X into the order c specified by WHICH and optionally applies the permutation to the c Real array Y. c c\Usage: c call csortc c ( WHICH, APPLY, N, X, Y ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> sort X into increasing order of magnitude. c 'SM' -> sort X into decreasing order of magnitude. c 'LR' -> sort X with real(X) in increasing algebraic order c 'SR' -> sort X with real(X) in decreasing algebraic order c 'LI' -> sort X with imag(X) in increasing algebraic order c 'SI' -> sort X with imag(X) in decreasing algebraic order c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to array Y. c APPLY = .FALSE. -> do not apply the sorted order to array Y. c c N Integer. (INPUT) c Size of the arrays. c c X Complex array of length N. (INPUT/OUTPUT) c This is the array to be sorted. c c Y Complex array of length N. (INPUT/OUTPUT) c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines called: c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine csortc (which, apply, n, x, y) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Complex & x(0:n-1), y(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Complex & temp Real & temp1, temp2 c c %--------------------% c | External functions | c %--------------------% c Real & slapy2 c c %--------------------% c | Intrinsic Functions | c %--------------------% Intrinsic & real, aimag c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'LM') then c c %--------------------------------------------% c | Sort X into increasing order of magnitude. | c %--------------------------------------------% c 10 continue if (igap .eq. 0) go to 9000 c do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c temp1 = slapy2(real(x(j)),aimag(x(j))) temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap))) c if (temp1.gt.temp2) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 30 end if j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c %--------------------------------------------% c | Sort X into decreasing order of magnitude. | c %--------------------------------------------% c 40 continue if (igap .eq. 0) go to 9000 c do 60 i = igap, n-1 j = i-igap 50 continue c if (j .lt. 0) go to 60 c temp1 = slapy2(real(x(j)),aimag(x(j))) temp2 = slapy2(real(x(j+igap)),aimag(x(j+igap))) c if (temp1.lt.temp2) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LR') then c c %------------------------------------------------% c | Sort XREAL into increasing order of algebraic. | c %------------------------------------------------% c 70 continue if (igap .eq. 0) go to 9000 c do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (real(x(j)).gt.real(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'SR') then c c %------------------------------------------------% c | Sort XREAL into decreasing order of algebraic. | c %------------------------------------------------% c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (real(x(j)).lt.real(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 c else if (which .eq. 'LI') then c c %--------------------------------------------% c | Sort XIMAG into increasing algebraic order | c %--------------------------------------------% c 130 continue if (igap .eq. 0) go to 9000 do 150 i = igap, n-1 j = i-igap 140 continue c if (j.lt.0) go to 150 c if (aimag(x(j)).gt.aimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 150 endif j = j-igap go to 140 150 continue igap = igap / 2 go to 130 c else if (which .eq. 'SI') then c c %---------------------------------------------% c | Sort XIMAG into decreasing algebraic order | c %---------------------------------------------% c 160 continue if (igap .eq. 0) go to 9000 do 180 i = igap, n-1 j = i-igap 170 continue c if (j.lt.0) go to 180 c if (aimag(x(j)).lt.aimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 180 endif j = j-igap go to 170 180 continue igap = igap / 2 go to 160 end if c 9000 continue return c c %---------------% c | End of csortc | c %---------------% c end arpack-akloeckner-07/SRC/cstatn.f0000644000175000017500000000230506136215715016573 0ustar andreasandreasc c\SCCS Information: @(#) c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c %---------------------------------------------% c | Initialize statistic and timing information | c | for complex nonsymmetric Arnoldi code. | c %---------------------------------------------% subroutine cstatn c c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c include 'stat.h' c %-----------------------% c | Executable Statements | c %-----------------------% nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 tcaupd = 0.0E+0 tcaup2 = 0.0E+0 tcaitr = 0.0E+0 tceigh = 0.0E+0 tcgets = 0.0E+0 tcapps = 0.0E+0 tcconv = 0.0E+0 titref = 0.0E+0 tgetv0 = 0.0E+0 trvec = 0.0E+0 c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% tmvopx = 0.0E+0 tmvbx = 0.0E+0 return c c %---------------% c | End of cstatn | c %---------------% c end arpack-akloeckner-07/SRC/zgetv0.f0000644000175000017500000003127410670622032016515 0ustar andreasandreasc\BeginDoc c c\Name: zgetv0 c c\Description: c Generate a random initial residual vector for the Arnoldi process. c Force the residual vector to be in the range of the operator OP. c c\Usage: c call zgetv0 c ( IDO, BMAT, ITRY, INITV, N, J, V, LDV, RESID, RNORM, c IPNTR, WORKD, IERR ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to zgetv0. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 99: done c ------------------------------------------------------------- c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B in the (generalized) c eigenvalue problem A*x = lambda*B*x. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*B*x c c ITRY Integer. (INPUT) c ITRY counts the number of times that zgetv0 is called. c It should be set to 1 on the initial call to zgetv0. c c INITV Logical variable. (INPUT) c .TRUE. => the initial residual vector is given in RESID. c .FALSE. => generate a random initial residual vector. c c N Integer. (INPUT) c Dimension of the problem. c c J Integer. (INPUT) c Index of the residual vector to be generated, with respect to c the Arnoldi process. J > 1 in case of a "restart". c c V Complex*16 N by J array. (INPUT) c The first J-1 columns of V contain the current Arnoldi basis c if this is a "restart". c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c Initial residual vector to be generated. If RESID is c provided, force RESID into the range of the operator OP. c c RNORM Double precision scalar. (OUTPUT) c B-norm of the generated residual. c c IPNTR Integer array of length 3. (OUTPUT) c c WORKD Complex*16 work array of length 2*N. (REVERSE COMMUNICATION). c On exit, WORK(1:N) = B*RESID to be used in SSAITR. c c IERR Integer. (OUTPUT) c = 0: Normal exit. c = -1: Cannot generate a nontrivial restarted residual vector c in the range of the operator OP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c arscnd ARPACK utility routine for timing. c zvout ARPACK utility routine that prints vectors. c zlarnv LAPACK routine for generating a random vector. c zgemv Level 2 BLAS routine for matrix vector multiplication. c zcopy Level 1 BLAS that copies one vector to another. c zdotc Level 1 BLAS that computes the scalar product of two vectors. c dznrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: getv0.F SID: 2.3 DATE OF SID: 08/27/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine zgetv0 & ( ido, bmat, itry, initv, n, j, v, ldv, resid, rnorm, & ipntr, workd, ierr ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 logical initv integer ido, ierr, itry, j, ldv, n Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Complex*16 & resid(n), v(ldv,j), workd(2*n) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rzero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), & rzero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical first, inits, orth integer idist, iseed(4), iter, msglvl, jj Double precision & rnorm0 Complex*16 & cnorm save first, iseed, inits, iter, msglvl, orth, rnorm0 c c %----------------------% c | External Subroutines | c %----------------------% c external zcopy, zgemv, zlarnv, zvout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Double precision & dznrm2, dlapy2 Complex*16 & zdotc external zdotc, dznrm2, dlapy2 c c %-----------------% c | Data Statements | c %-----------------% c data inits /.true./ c c %-----------------------% c | Executable Statements | c %-----------------------% c c c %-----------------------------------% c | Initialize the seed of the LAPACK | c | random number generator | c %-----------------------------------% c if (inits) then iseed(1) = 1 iseed(2) = 3 iseed(3) = 5 iseed(4) = 7 inits = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mgetv0 c ierr = 0 iter = 0 first = .FALSE. orth = .FALSE. c c %-----------------------------------------------------% c | Possibly generate a random starting vector in RESID | c | Use a LAPACK random number generator used by the | c | matrix generation routines. | c | idist = 1: uniform (0,1) distribution; | c | idist = 2: uniform (-1,1) distribution; | c | idist = 3: normal (0,1) distribution; | c %-----------------------------------------------------% c if (.not.initv) then idist = 2 call zlarnv (idist, iseed, n, resid) end if c c %----------------------------------------------------------% c | Force the starting vector into the range of OP to handle | c | the generalized problem when B is possibly (singular). | c %----------------------------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nopx = nopx + 1 ipntr(1) = 1 ipntr(2) = n + 1 call zcopy (n, resid, 1, workd, 1) ido = -1 go to 9000 end if end if c c %----------------------------------------% c | Back from computing B*(initial-vector) | c %----------------------------------------% c if (first) go to 20 c c %-----------------------------------------------% c | Back from computing B*(orthogonalized-vector) | c %-----------------------------------------------% c if (orth) go to 40 c call arscnd (t3) tmvopx = tmvopx + (t3 - t2) c c %------------------------------------------------------% c | Starting vector is now in the range of OP; r = OP*r; | c | Compute B-norm of starting vector. | c %------------------------------------------------------% c call arscnd (t2) first = .TRUE. if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, workd(n+1), 1, resid, 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd, 1) end if c 20 continue c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c first = .FALSE. if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd, 1) rnorm0 = sqrt(dlapy2(dble(cnorm),dimag(cnorm))) else if (bmat .eq. 'I') then rnorm0 = dznrm2(n, resid, 1) end if rnorm = rnorm0 c c %---------------------------------------------% c | Exit if this is the very first Arnoldi step | c %---------------------------------------------% c if (j .eq. 1) go to 50 c c %---------------------------------------------------------------- c | Otherwise need to B-orthogonalize the starting vector against | c | the current Arnoldi basis using Gram-Schmidt with iter. ref. | c | This is the case where an invariant subspace is encountered | c | in the middle of the Arnoldi factorization. | c | | c | s = V^{T}*B*r; r = r - V*s; | c | | c | Stopping criteria used for iter. ref. is discussed in | c | Parlett's book, page 107 and in Gragg & Reichel TOMS paper. | c %---------------------------------------------------------------% c orth = .TRUE. 30 continue c call zgemv ('C', n, j-1, one, v, ldv, workd, 1, & zero, workd(n+1), 1) call zgemv ('N', n, j-1, -one, v, ldv, workd(n+1), 1, & one, resid, 1) c c %----------------------------------------------------------% c | Compute the B-norm of the orthogonalized starting vector | c %----------------------------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd, 1) end if c 40 continue c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd, 1) rnorm = sqrt(dlapy2(dble(cnorm),dimag(cnorm))) else if (bmat .eq. 'I') then rnorm = dznrm2(n, resid, 1) end if c c %--------------------------------------% c | Check for further orthogonalization. | c %--------------------------------------% c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm0, ndigit, & '_getv0: re-orthonalization ; rnorm0 is') call dvout (logfil, 1, rnorm, ndigit, & '_getv0: re-orthonalization ; rnorm is') end if c if (rnorm .gt. 0.717*rnorm0) go to 50 c iter = iter + 1 if (iter .le. 1) then c c %-----------------------------------% c | Perform iterative refinement step | c %-----------------------------------% c rnorm0 = rnorm go to 30 else c c %------------------------------------% c | Iterative refinement step "failed" | c %------------------------------------% c do 45 jj = 1, n resid(jj) = zero 45 continue rnorm = rzero ierr = -1 end if c 50 continue c if (msglvl .gt. 0) then call dvout (logfil, 1, rnorm, ndigit, & '_getv0: B-norm of initial / restarted starting vector') end if if (msglvl .gt. 2) then call zvout (logfil, n, resid, ndigit, & '_getv0: initial / restarted starting vector') end if ido = 99 c call arscnd (t1) tgetv0 = tgetv0 + (t1 - t0) c 9000 continue return c c %---------------% c | End of zgetv0 | c %---------------% c end arpack-akloeckner-07/SRC/znaitr.f0000644000175000017500000007463310670622032016613 0ustar andreasandreasc\BeginDoc c c\Name: znaitr c c\Description: c Reverse communication interface for applying NP additional steps to c a K step nonsymmetric Arnoldi factorization. c c Input: OP*V_{k} - V_{k}*H = r_{k}*e_{k}^T c c with (V_{k}^T)*B*V_{k} = I, (V_{k}^T)*B*r_{k} = 0. c c Output: OP*V_{k+p} - V_{k+p}*H = r_{k+p}*e_{k+p}^T c c with (V_{k+p}^T)*B*V_{k+p} = I, (V_{k+p}^T)*B*r_{k+p} = 0. c c where OP and B are as in znaupd. The B-norm of r_{k+p} is also c computed and returned. c c\Usage: c call znaitr c ( IDO, BMAT, N, K, NP, NB, RESID, RNORM, V, LDV, H, LDH, c IPNTR, WORKD, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c This is for the restart phase to force the new c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y, c IPNTR(3) is the pointer into WORK for B * X. c IDO = 2: compute Y = B * X where c IPNTR(1) is the pointer into WORK for X, c IPNTR(2) is the pointer into WORK for Y. c IDO = 99: done c ------------------------------------------------------------- c When the routine is used in the "shift-and-invert" mode, the c vector B * Q is already available and do not need to be c recomputed in forming OP * Q. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. See znaupd. c B = 'I' -> standard eigenvalue problem A*x = lambda*x c B = 'G' -> generalized eigenvalue problem A*x = lambda*M**x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c K Integer. (INPUT) c Current size of V and H. c c NP Integer. (INPUT) c Number of additional Arnoldi steps to take. c c NB Integer. (INPUT) c Blocksize to be used in the recurrence. c Only work for NB = 1 right now. The goal is to have a c program that implement both the block and non-block method. c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c On INPUT: RESID contains the residual vector r_{k}. c On OUTPUT: RESID contains the residual vector r_{k+p}. c c RNORM Double precision scalar. (INPUT/OUTPUT) c B-norm of the starting residual on input. c B-norm of the updated residual r_{k+p} on output. c c V Complex*16 N by K+NP array. (INPUT/OUTPUT) c On INPUT: V contains the Arnoldi vectors in the first K c columns. c On OUTPUT: V contains the new NP Arnoldi vectors in the next c NP columns. The first K columns are unchanged. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex*16 (K+NP) by (K+NP) array. (INPUT/OUTPUT) c H is used to store the generated upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORK for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The calling program should not c use WORKD as temporary workspace during the iteration !!!!!! c On input, WORKD(1:N) = B*RESID and is used to save some c computation at the first step. c c INFO Integer. (OUTPUT) c = 0: Normal exit. c > 0: Size of the spanning invariant subspace of OP found. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c zgetv0 ARPACK routine to generate the initial vector. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c zlanhs LAPACK routine that computes various norms of a matrix. c zlascl LAPACK routine for careful scaling of a matrix. c dlabad LAPACK routine for defining the underflow and overflow c limits. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zgemv Level 2 BLAS routine for matrix vector multiplication. c zaxpy Level 1 BLAS that computes a vector triad. c zcopy Level 1 BLAS that copies one vector to another . c zdotc Level 1 BLAS that computes the scalar product of two vectors. c zscal Level 1 BLAS that scales a vector. c zdscal Level 1 BLAS that scales a complex vector by a real number. c dznrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naitr.F SID: 2.3 DATE OF SID: 8/27/96 RELEASE: 2 c c\Remarks c The algorithm implemented is: c c restart = .false. c Given V_{k} = [v_{1}, ..., v_{k}], r_{k}; c r_{k} contains the initial residual vector even for k = 0; c Also assume that rnorm = || B*r_{k} || and B*r_{k} are already c computed by the calling program. c c betaj = rnorm ; p_{k+1} = B*r_{k} ; c For j = k+1, ..., k+np Do c 1) if ( betaj < tol ) stop or restart depending on j. c ( At present tol is zero ) c if ( restart ) generate a new starting vector. c 2) v_{j} = r(j-1)/betaj; V_{j} = [V_{j-1}, v_{j}]; c p_{j} = p_{j}/betaj c 3) r_{j} = OP*v_{j} where OP is defined as in znaupd c For shift-invert mode p_{j} = B*v_{j} is already available. c wnorm = || OP*v_{j} || c 4) Compute the j-th step residual vector. c w_{j} = V_{j}^T * B * OP * v_{j} c r_{j} = OP*v_{j} - V_{j} * w_{j} c H(:,j) = w_{j}; c H(j,j-1) = rnorm c rnorm = || r_(j) || c If (rnorm > 0.717*wnorm) accept step and go back to 1) c 5) Re-orthogonalization step: c s = V_{j}'*B*r_{j} c r_{j} = r_{j} - V_{j}*s; rnorm1 = || r_{j} || c alphaj = alphaj + s_{j}; c 6) Iterative refinement step: c If (rnorm1 > 0.717*rnorm) then c rnorm = rnorm1 c accept step and go back to 1) c Else c rnorm = rnorm1 c If this is the first time in step 6), go to 5) c Else r_{j} lies in the span of V_{j} numerically. c Set r_{j} = 0 and rnorm = 0; go to 1) c EndIf c End Do c c\EndLib c c----------------------------------------------------------------------- c subroutine znaitr & (ido, bmat, n, k, np, nb, resid, rnorm, v, ldv, h, ldh, & ipntr, workd, info) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1 integer ido, info, k, ldh, ldv, n, nb, np Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(3) Complex*16 & h(ldh,k+np), resid(n), v(ldv,k+np), workd(3*n) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rone, rzero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), & rone = 1.0D+0, rzero = 0.0D+0) c c %--------------% c | Local Arrays | c %--------------% c Double precision & rtemp(2) c c %---------------% c | Local Scalars | c %---------------% c logical first, orth1, orth2, rstart, step3, step4 integer ierr, i, infol, ipj, irj, ivj, iter, itry, j, msglvl, & jj Double precision & ovfl, smlnum, tst1, ulp, unfl, betaj, & temp1, rnorm1, wnorm Complex*16 & cnorm c save first, orth1, orth2, rstart, step3, step4, & ierr, ipj, irj, ivj, iter, itry, j, msglvl, ovfl, & betaj, rnorm1, smlnum, ulp, unfl, wnorm c c %----------------------% c | External Subroutines | c %----------------------% c external zaxpy, zcopy, zscal, zdscal, zgemv, zgetv0, & dlabad, zvout, zmout, ivout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Complex*16 & zdotc Double precision & dlamch, dznrm2, zlanhs, dlapy2 external zdotc, dznrm2, zlanhs, dlamch, dlapy2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic dimag, dble, max, sqrt c c %-----------------% c | Data statements | c %-----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------% c | Set machine-dependent constants for the | c | the splitting and deflation criterion. | c | If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine zlahqr | c %-----------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = dble(one / unfl) call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mcaitr c c %------------------------------% c | Initial call to this routine | c %------------------------------% c info = 0 step3 = .false. step4 = .false. rstart = .false. orth1 = .false. orth2 = .false. j = k + 1 ipj = 1 irj = ipj + n ivj = irj + n end if c c %-------------------------------------------------% c | When in reverse communication mode one of: | c | STEP3, STEP4, ORTH1, ORTH2, RSTART | c | will be .true. when .... | c | STEP3: return from computing OP*v_{j}. | c | STEP4: return from computing B-norm of OP*v_{j} | c | ORTH1: return from computing B-norm of r_{j+1} | c | ORTH2: return from computing B-norm of | c | correction to the residual vector. | c | RSTART: return from OP computations needed by | c | zgetv0. | c %-------------------------------------------------% c if (step3) go to 50 if (step4) go to 60 if (orth1) go to 70 if (orth2) go to 90 if (rstart) go to 30 c c %-----------------------------% c | Else this is the first step | c %-----------------------------% c c %--------------------------------------------------------------% c | | c | A R N O L D I I T E R A T I O N L O O P | c | | c | Note: B*r_{j-1} is already in WORKD(1:N)=WORKD(IPJ:IPJ+N-1) | c %--------------------------------------------------------------% 1000 continue c if (msglvl .gt. 1) then call ivout (logfil, 1, j, ndigit, & '_naitr: generating Arnoldi vector number') call dvout (logfil, 1, rnorm, ndigit, & '_naitr: B-norm of the current residual is') end if c c %---------------------------------------------------% c | STEP 1: Check if the B norm of j-th residual | c | vector is zero. Equivalent to determine whether | c | an exact j-step Arnoldi factorization is present. | c %---------------------------------------------------% c betaj = rnorm if (rnorm .gt. rzero) go to 40 c c %---------------------------------------------------% c | Invariant subspace found, generate a new starting | c | vector which is orthogonal to the current Arnoldi | c | basis and continue the iteration. | c %---------------------------------------------------% c if (msglvl .gt. 0) then call ivout (logfil, 1, j, ndigit, & '_naitr: ****** RESTART AT STEP ******') end if c c %---------------------------------------------% c | ITRY is the loop variable that controls the | c | maximum amount of times that a restart is | c | attempted. NRSTRT is used by stat.h | c %---------------------------------------------% c betaj = rzero nrstrt = nrstrt + 1 itry = 1 20 continue rstart = .true. ido = 0 30 continue c c %--------------------------------------% c | If in reverse communication mode and | c | RSTART = .true. flow returns here. | c %--------------------------------------% c call zgetv0 (ido, bmat, itry, .false., n, j, v, ldv, & resid, rnorm, ipntr, workd, ierr) if (ido .ne. 99) go to 9000 if (ierr .lt. 0) then itry = itry + 1 if (itry .le. 3) go to 20 c c %------------------------------------------------% c | Give up after several restart attempts. | c | Set INFO to the size of the invariant subspace | c | which spans OP and exit. | c %------------------------------------------------% c info = j - 1 call arscnd (t1) tcaitr = tcaitr + (t1 - t0) ido = 99 go to 9000 end if c 40 continue c c %---------------------------------------------------------% c | STEP 2: v_{j} = r_{j-1}/rnorm and p_{j} = p_{j}/rnorm | c | Note that p_{j} = B*r_{j-1}. In order to avoid overflow | c | when reciprocating a small RNORM, test against lower | c | machine bound. | c %---------------------------------------------------------% c call zcopy (n, resid, 1, v(1,j), 1) if ( rnorm .ge. unfl) then temp1 = rone / rnorm call zdscal (n, temp1, v(1,j), 1) call zdscal (n, temp1, workd(ipj), 1) else c c %-----------------------------------------% c | To scale both v_{j} and p_{j} carefully | c | use LAPACK routine zlascl | c %-----------------------------------------% c call zlascl ('General', i, i, rnorm, rone, & n, 1, v(1,j), n, infol) call zlascl ('General', i, i, rnorm, rone, & n, 1, workd(ipj), n, infol) end if c c %------------------------------------------------------% c | STEP 3: r_{j} = OP*v_{j}; Note that p_{j} = B*v_{j} | c | Note that this is not quite yet r_{j}. See STEP 4 | c %------------------------------------------------------% c step3 = .true. nopx = nopx + 1 call arscnd (t2) call zcopy (n, v(1,j), 1, workd(ivj), 1) ipntr(1) = ivj ipntr(2) = irj ipntr(3) = ipj ido = 1 c c %-----------------------------------% c | Exit in order to compute OP*v_{j} | c %-----------------------------------% c go to 9000 50 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IRJ:IRJ+N-1) := OP*v_{j} | c | if step3 = .true. | c %----------------------------------% c call arscnd (t3) tmvopx = tmvopx + (t3 - t2) step3 = .false. c c %------------------------------------------% c | Put another copy of OP*v_{j} into RESID. | c %------------------------------------------% c call zcopy (n, workd(irj), 1, resid, 1) c c %---------------------------------------% c | STEP 4: Finish extending the Arnoldi | c | factorization to length j. | c %---------------------------------------% c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 step4 = .true. ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-------------------------------------% c | Exit in order to compute B*OP*v_{j} | c %-------------------------------------% c go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd(ipj), 1) end if 60 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(IPJ:IPJ+N-1) := B*OP*v_{j} | c | if step4 = .true. | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c step4 = .false. c c %-------------------------------------% c | The following is needed for STEP 5. | c | Compute the B-norm of OP*v_{j}. | c %-------------------------------------% c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) wnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then wnorm = dznrm2(n, resid, 1) end if c c %-----------------------------------------% c | Compute the j-th residual corresponding | c | to the j step factorization. | c | Use Classical Gram Schmidt and compute: | c | w_{j} <- V_{j}^T * B * OP * v_{j} | c | r_{j} <- OP*v_{j} - V_{j} * w_{j} | c %-----------------------------------------% c c c %------------------------------------------% c | Compute the j Fourier coefficients w_{j} | c | WORKD(IPJ:IPJ+N-1) contains B*OP*v_{j}. | c %------------------------------------------% c call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1, & zero, h(1,j), 1) c c %--------------------------------------% c | Orthogonalize r_{j} against V_{j}. | c | RESID contains OP*v_{j}. See STEP 3. | c %--------------------------------------% c call zgemv ('N', n, j, -one, v, ldv, h(1,j), 1, & one, resid, 1) c if (j .gt. 1) h(j,j-1) = dcmplx(betaj, rzero) c call arscnd (t4) c orth1 = .true. c call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %----------------------------------% c | Exit in order to compute B*r_{j} | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd(ipj), 1) end if 70 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH1 = .true. | c | WORKD(IPJ:IPJ+N-1) := B*r_{j}. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c orth1 = .false. c c %------------------------------% c | Compute the B-norm of r_{j}. | c %------------------------------% c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) rnorm = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm = dznrm2(n, resid, 1) end if c c %-----------------------------------------------------------% c | STEP 5: Re-orthogonalization / Iterative refinement phase | c | Maximum NITER_ITREF tries. | c | | c | s = V_{j}^T * B * r_{j} | c | r_{j} = r_{j} - V_{j}*s | c | alphaj = alphaj + s_{j} | c | | c | The stopping criteria used for iterative refinement is | c | discussed in Parlett's book SEP, page 107 and in Gragg & | c | Reichel ACM TOMS paper; Algorithm 686, Dec. 1990. | c | Determine if we need to correct the residual. The goal is | c | to enforce ||v(:,1:j)^T * r_{j}|| .le. eps * || r_{j} || | c | The following test determines whether the sine of the | c | angle between OP*x and the computed residual is less | c | than or equal to 0.717. | c %-----------------------------------------------------------% c if ( rnorm .gt. 0.717*wnorm ) go to 100 c iter = 0 nrorth = nrorth + 1 c c %---------------------------------------------------% c | Enter the Iterative refinement phase. If further | c | refinement is necessary, loop back here. The loop | c | variable is ITER. Perform a step of Classical | c | Gram-Schmidt using all the Arnoldi vectors V_{j} | c %---------------------------------------------------% c 80 continue c if (msglvl .gt. 2) then rtemp(1) = wnorm rtemp(2) = rnorm call dvout (logfil, 2, rtemp, ndigit, & '_naitr: re-orthogonalization; wnorm and rnorm are') call zvout (logfil, j, h(1,j), ndigit, & '_naitr: j-th column of H') end if c c %----------------------------------------------------% c | Compute V_{j}^T * B * r_{j}. | c | WORKD(IRJ:IRJ+J-1) = v(:,1:J)'*WORKD(IPJ:IPJ+N-1). | c %----------------------------------------------------% c call zgemv ('C', n, j, one, v, ldv, workd(ipj), 1, & zero, workd(irj), 1) c c %---------------------------------------------% c | Compute the correction to the residual: | c | r_{j} = r_{j} - V_{j} * WORKD(IRJ:IRJ+J-1). | c | The correction to H is v(:,1:J)*H(1:J,1:J) | c | + v(:,1:J)*WORKD(IRJ:IRJ+J-1)*e'_j. | c %---------------------------------------------% c call zgemv ('N', n, j, -one, v, ldv, workd(irj), 1, & one, resid, 1) call zaxpy (j, one, workd(irj), 1, h(1,j), 1) c orth2 = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, resid, 1, workd(irj), 1) ipntr(1) = irj ipntr(2) = ipj ido = 2 c c %-----------------------------------% c | Exit in order to compute B*r_{j}. | c | r_{j} is the corrected residual. | c %-----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd(ipj), 1) end if 90 continue c c %---------------------------------------------------% c | Back from reverse communication if ORTH2 = .true. | c %---------------------------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c c %-----------------------------------------------------% c | Compute the B-norm of the corrected residual r_{j}. | c %-----------------------------------------------------% c if (bmat .eq. 'G') then cnorm = zdotc (n, resid, 1, workd(ipj), 1) rnorm1 = sqrt( dlapy2(dble(cnorm),dimag(cnorm)) ) else if (bmat .eq. 'I') then rnorm1 = dznrm2(n, resid, 1) end if c if (msglvl .gt. 0 .and. iter .gt. 0 ) then call ivout (logfil, 1, j, ndigit, & '_naitr: Iterative refinement for Arnoldi residual') if (msglvl .gt. 2) then rtemp(1) = rnorm rtemp(2) = rnorm1 call dvout (logfil, 2, rtemp, ndigit, & '_naitr: iterative refinement ; rnorm and rnorm1 are') end if end if c c %-----------------------------------------% c | Determine if we need to perform another | c | step of re-orthogonalization. | c %-----------------------------------------% c if ( rnorm1 .gt. 0.717*rnorm ) then c c %---------------------------------------% c | No need for further refinement. | c | The cosine of the angle between the | c | corrected residual vector and the old | c | residual vector is greater than 0.717 | c | In other words the corrected residual | c | and the old residual vector share an | c | angle of less than arcCOS(0.717) | c %---------------------------------------% c rnorm = rnorm1 c else c c %-------------------------------------------% c | Another step of iterative refinement step | c | is required. NITREF is used by stat.h | c %-------------------------------------------% c nitref = nitref + 1 rnorm = rnorm1 iter = iter + 1 if (iter .le. 1) go to 80 c c %-------------------------------------------------% c | Otherwise RESID is numerically in the span of V | c %-------------------------------------------------% c do 95 jj = 1, n resid(jj) = zero 95 continue rnorm = rzero end if c c %----------------------------------------------% c | Branch here directly if iterative refinement | c | wasn't necessary or after at most NITER_REF | c | steps of iterative refinement. | c %----------------------------------------------% c 100 continue c rstart = .false. orth2 = .false. c call arscnd (t5) titref = titref + (t5 - t4) c c %------------------------------------% c | STEP 6: Update j = j+1; Continue | c %------------------------------------% c j = j + 1 if (j .gt. k+np) then call arscnd (t1) tcaitr = tcaitr + (t1 - t0) ido = 99 do 110 i = max(1,k), k+np-1 c c %--------------------------------------------% c | Check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine zlahqr | c %--------------------------------------------% c tst1 = dlapy2(dble(h(i,i)),dimag(h(i,i))) & + dlapy2(dble(h(i+1,i+1)), dimag(h(i+1,i+1))) if( tst1.eq.dble(zero) ) & tst1 = zlanhs( '1', k+np, h, ldh, workd(n+1) ) if( dlapy2(dble(h(i+1,i)),dimag(h(i+1,i))) .le. & max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 110 continue c if (msglvl .gt. 2) then call zmout (logfil, k+np, k+np, h, ldh, ndigit, & '_naitr: Final upper Hessenberg matrix H of order K+NP') end if c go to 9000 end if c c %--------------------------------------------------------% c | Loop back to extend the factorization by another step. | c %--------------------------------------------------------% c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 9000 continue return c c %---------------% c | End of znaitr | c %---------------% c end arpack-akloeckner-07/SRC/znapps.f0000644000175000017500000004233110670622032016605 0ustar andreasandreasc\BeginDoc c c\Name: znapps c c\Description: c Given the Arnoldi factorization c c A*V_{k} - V_{k}*H_{k} = r_{k+p}*e_{k+p}^T, c c apply NP implicit shifts resulting in c c A*(V_{k}*Q) - (V_{k}*Q)*(Q^T* H_{k}*Q) = r_{k+p}*e_{k+p}^T * Q c c where Q is an orthogonal matrix which is the product of rotations c and reflections resulting from the NP bulge change sweeps. c The updated Arnoldi factorization becomes: c c A*VNEW_{k} - VNEW_{k}*HNEW_{k} = rnew_{k}*e_{k}^T. c c\Usage: c call znapps c ( N, KEV, NP, SHIFT, V, LDV, H, LDH, RESID, Q, LDQ, c WORKL, WORKD ) c c\Arguments c N Integer. (INPUT) c Problem size, i.e. size of matrix A. c c KEV Integer. (INPUT/OUTPUT) c KEV+NP is the size of the input matrix H. c KEV is the size of the updated matrix HNEW. c c NP Integer. (INPUT) c Number of implicit shifts to be applied. c c SHIFT Complex*16 array of length NP. (INPUT) c The shifts to be applied. c c V Complex*16 N by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, V contains the current KEV+NP Arnoldi vectors. c On OUTPUT, V contains the updated KEV Arnoldi vectors c in the first KEV columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex*16 (KEV+NP) by (KEV+NP) array. (INPUT/OUTPUT) c On INPUT, H contains the current KEV+NP by KEV+NP upper c Hessenberg matrix of the Arnoldi factorization. c On OUTPUT, H contains the updated KEV by KEV upper Hessenberg c matrix in the KEV leading submatrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c On INPUT, RESID contains the the residual vector r_{k+p}. c On OUTPUT, RESID is the update residual vector rnew_{k} c in the first KEV locations. c c Q Complex*16 KEV+NP by KEV+NP work array. (WORKSPACE) c Work array used to accumulate the rotations and reflections c during the bulge chase sweep. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex*16 work array of length (KEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c WORKD Complex*16 work array of length 2*N. (WORKSPACE) c Distributed array used in the application of the accumulated c orthogonal matrix Q. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c\Routines called: c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c zlacpy LAPACK matrix copy routine. c zlanhs LAPACK routine that computes various norms of a matrix. c zlartg LAPACK Givens rotation construction routine. c zlaset LAPACK matrix initialization routine. c dlabad LAPACK routine for defining the underflow and overflow c limits. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zgemv Level 2 BLAS routine for matrix vector multiplication. c zaxpy Level 1 BLAS that computes a vector triad. c zcopy Level 1 BLAS that copies one vector to another. c zscal Level 1 BLAS that scales a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: napps.F SID: 2.3 DATE OF SID: 3/28/97 RELEASE: 2 c c\Remarks c 1. In this version, each shift is applied to all the sublocks of c the Hessenberg matrix H and not just to the submatrix that it c comes from. Deflation as in LAPACK routine zlahqr (QR algorithm c for upper Hessenberg matrices ) is used. c Upon output, the subdiagonals of H are enforced to be non-negative c real numbers. c c\EndLib c c----------------------------------------------------------------------- c subroutine znapps & ( n, kev, np, shift, v, ldv, h, ldh, resid, q, ldq, & workl, workd ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer kev, ldh, ldq, ldv, n, np c c %-----------------% c | Array Arguments | c %-----------------% c Complex*16 & h(ldh,kev+np), resid(n), shift(np), & v(ldv,kev+np), q(ldq,kev+np), workd(2*n), workl(kev+np) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rzero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), & rzero = 0.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c integer i, iend, istart, j, jj, kplusp, msglvl logical first Complex*16 & cdum, f, g, h11, h21, r, s, sigma, t Double precision & c, ovfl, smlnum, ulp, unfl, tst1 save first, ovfl, smlnum, ulp, unfl c c %----------------------% c | External Subroutines | c %----------------------% c external zaxpy, zcopy, zgemv, zscal, zlacpy, zlartg, & zvout, zlaset, dlabad, zmout, arscnd, ivout c c %--------------------% c | External Functions | c %--------------------% c Double precision & zlanhs, dlamch, dlapy2 external zlanhs, dlamch, dlapy2 c c %----------------------% c | Intrinsics Functions | c %----------------------% c intrinsic abs, dimag, conjg, dcmplx, max, min, dble c c %---------------------% c | Statement Functions | c %---------------------% c Double precision & zabs1 zabs1( cdum ) = abs( dble( cdum ) ) + abs( dimag( cdum ) ) c c %----------------% c | Data statments | c %----------------% c data first / .true. / c c %-----------------------% c | Executable Statements | c %-----------------------% c if (first) then c c %-----------------------------------------------% c | Set machine-dependent constants for the | c | stopping criterion. If norm(H) <= sqrt(OVFL), | c | overflow should not occur. | c | REFERENCE: LAPACK subroutine zlahqr | c %-----------------------------------------------% c unfl = dlamch( 'safe minimum' ) ovfl = dble(one / unfl) call dlabad( unfl, ovfl ) ulp = dlamch( 'precision' ) smlnum = unfl*( n / ulp ) first = .false. end if c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mcapps c kplusp = kev + np c c %--------------------------------------------% c | Initialize Q to the identity to accumulate | c | the rotations and reflections | c %--------------------------------------------% c call zlaset ('All', kplusp, kplusp, zero, one, q, ldq) c c %----------------------------------------------% c | Quick return if there are no shifts to apply | c %----------------------------------------------% c if (np .eq. 0) go to 9000 c c %----------------------------------------------% c | Chase the bulge with the application of each | c | implicit shift. Each shift is applied to the | c | whole matrix including each block. | c %----------------------------------------------% c do 110 jj = 1, np sigma = shift(jj) c if (msglvl .gt. 2 ) then call ivout (logfil, 1, jj, ndigit, & '_napps: shift number.') call zvout (logfil, 1, sigma, ndigit, & '_napps: Value of the shift ') end if c istart = 1 20 continue c do 30 i = istart, kplusp-1 c c %----------------------------------------% c | Check for splitting and deflation. Use | c | a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine zlahqr | c %----------------------------------------% c tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) ) if( tst1.eq.rzero ) & tst1 = zlanhs( '1', kplusp-jj+1, h, ldh, workl ) if ( abs(dble(h(i+1,i))) & .le. max(ulp*tst1, smlnum) ) then if (msglvl .gt. 0) then call ivout (logfil, 1, i, ndigit, & '_napps: matrix splitting at row/column no.') call ivout (logfil, 1, jj, ndigit, & '_napps: matrix splitting with shift number.') call zvout (logfil, 1, h(i+1,i), ndigit, & '_napps: off diagonal element.') end if iend = i h(i+1,i) = zero go to 40 end if 30 continue iend = kplusp 40 continue c if (msglvl .gt. 2) then call ivout (logfil, 1, istart, ndigit, & '_napps: Start of current block ') call ivout (logfil, 1, iend, ndigit, & '_napps: End of current block ') end if c c %------------------------------------------------% c | No reason to apply a shift to block of order 1 | c | or if the current block starts after the point | c | of compression since we'll discard this stuff | c %------------------------------------------------% c if ( istart .eq. iend .or. istart .gt. kev) go to 100 c h11 = h(istart,istart) h21 = h(istart+1,istart) f = h11 - sigma g = h21 c do 80 i = istart, iend-1 c c %------------------------------------------------------% c | Construct the plane rotation G to zero out the bulge | c %------------------------------------------------------% c call zlartg (f, g, c, s, r) if (i .gt. istart) then h(i,i-1) = r h(i+1,i-1) = zero end if c c %---------------------------------------------% c | Apply rotation to the left of H; H <- G'*H | c %---------------------------------------------% c do 50 j = i, kplusp t = c*h(i,j) + s*h(i+1,j) h(i+1,j) = -conjg(s)*h(i,j) + c*h(i+1,j) h(i,j) = t 50 continue c c %---------------------------------------------% c | Apply rotation to the right of H; H <- H*G | c %---------------------------------------------% c do 60 j = 1, min(i+2,iend) t = c*h(j,i) + conjg(s)*h(j,i+1) h(j,i+1) = -s*h(j,i) + c*h(j,i+1) h(j,i) = t 60 continue c c %-----------------------------------------------------% c | Accumulate the rotation in the matrix Q; Q <- Q*G' | c %-----------------------------------------------------% c do 70 j = 1, min(i+jj, kplusp) t = c*q(j,i) + conjg(s)*q(j,i+1) q(j,i+1) = - s*q(j,i) + c*q(j,i+1) q(j,i) = t 70 continue c c %---------------------------% c | Prepare for next rotation | c %---------------------------% c if (i .lt. iend-1) then f = h(i+1,i) g = h(i+2,i) end if 80 continue c c %-------------------------------% c | Finished applying the shift. | c %-------------------------------% c 100 continue c c %---------------------------------------------------------% c | Apply the same shift to the next block if there is any. | c %---------------------------------------------------------% c istart = iend + 1 if (iend .lt. kplusp) go to 20 c c %---------------------------------------------% c | Loop back to the top to get the next shift. | c %---------------------------------------------% c 110 continue c c %---------------------------------------------------% c | Perform a similarity transformation that makes | c | sure that the compressed H will have non-negative | c | real subdiagonal elements. | c %---------------------------------------------------% c do 120 j=1,kev if ( dble( h(j+1,j) ) .lt. rzero .or. & dimag( h(j+1,j) ) .ne. rzero ) then t = h(j+1,j) / dlapy2(dble(h(j+1,j)),dimag(h(j+1,j))) call zscal( kplusp-j+1, conjg(t), h(j+1,j), ldh ) call zscal( min(j+2, kplusp), t, h(1,j+1), 1 ) call zscal( min(j+np+1,kplusp), t, q(1,j+1), 1 ) h(j+1,j) = dcmplx( dble( h(j+1,j) ), rzero ) end if 120 continue c do 130 i = 1, kev c c %--------------------------------------------% c | Final check for splitting and deflation. | c | Use a standard test as in the QR algorithm | c | REFERENCE: LAPACK subroutine zlahqr. | c | Note: Since the subdiagonals of the | c | compressed H are nonnegative real numbers, | c | we take advantage of this. | c %--------------------------------------------% c tst1 = zabs1( h( i, i ) ) + zabs1( h( i+1, i+1 ) ) if( tst1 .eq. rzero ) & tst1 = zlanhs( '1', kev, h, ldh, workl ) if( dble( h( i+1,i ) ) .le. max( ulp*tst1, smlnum ) ) & h(i+1,i) = zero 130 continue c c %-------------------------------------------------% c | Compute the (kev+1)-st column of (V*Q) and | c | temporarily store the result in WORKD(N+1:2*N). | c | This is needed in the residual update since we | c | cannot GUARANTEE that the corresponding entry | c | of H would be zero as in exact arithmetic. | c %-------------------------------------------------% c if ( dble( h(kev+1,kev) ) .gt. rzero ) & call zgemv ('N', n, kplusp, one, v, ldv, q(1,kev+1), 1, zero, & workd(n+1), 1) c c %----------------------------------------------------------% c | Compute column 1 to kev of (V*Q) in backward order | c | taking advantage of the upper Hessenberg structure of Q. | c %----------------------------------------------------------% c do 140 i = 1, kev call zgemv ('N', n, kplusp-i+1, one, v, ldv, & q(1,kev-i+1), 1, zero, workd, 1) call zcopy (n, workd, 1, v(1,kplusp-i+1), 1) 140 continue c c %-------------------------------------------------% c | Move v(:,kplusp-kev+1:kplusp) into v(:,1:kev). | c %-------------------------------------------------% c call zlacpy ('A', n, kev, v(1,kplusp-kev+1), ldv, v, ldv) c c %--------------------------------------------------------------% c | Copy the (kev+1)-st column of (V*Q) in the appropriate place | c %--------------------------------------------------------------% c if ( dble( h(kev+1,kev) ) .gt. rzero ) & call zcopy (n, workd(n+1), 1, v(1,kev+1), 1) c c %-------------------------------------% c | Update the residual vector: | c | r <- sigmak*r + betak*v(:,kev+1) | c | where | c | sigmak = (e_{kev+p}'*Q)*e_{kev} | c | betak = e_{kev+1}'*H*e_{kev} | c %-------------------------------------% c call zscal (n, q(kplusp,kev), resid, 1) if ( dble( h(kev+1,kev) ) .gt. rzero ) & call zaxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1) c if (msglvl .gt. 1) then call zvout (logfil, 1, q(kplusp,kev), ndigit, & '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}') call zvout (logfil, 1, h(kev+1,kev), ndigit, & '_napps: betak = e_{kev+1}^T*H*e_{kev}') call ivout (logfil, 1, kev, ndigit, & '_napps: Order of the final Hessenberg matrix ') if (msglvl .gt. 2) then call zmout (logfil, kev, kev, h, ldh, ndigit, & '_napps: updated Hessenberg matrix H for next iteration') end if c end if c 9000 continue call arscnd (t1) tcapps = tcapps + (t1 - t0) c return c c %---------------% c | End of znapps | c %---------------% c end arpack-akloeckner-07/SRC/znaup2.f0000644000175000017500000007134210670622032016515 0ustar andreasandreasc\BeginDoc c c\Name: znaup2 c c\Description: c Intermediate level interface called by znaupd . c c\Usage: c call znaup2 c ( IDO, BMAT, N, WHICH, NEV, NP, TOL, RESID, MODE, IUPD, c ISHIFT, MXITER, V, LDV, H, LDH, RITZ, BOUNDS, c Q, LDQ, WORKL, IPNTR, WORKD, RWORK, INFO ) c c\Arguments c c IDO, BMAT, N, WHICH, NEV, TOL, RESID: same as defined in znaupd . c MODE, ISHIFT, MXITER: see the definition of IPARAM in znaupd . c c NP Integer. (INPUT/OUTPUT) c Contains the number of implicit shifts to apply during c each Arnoldi iteration. c If ISHIFT=1, NP is adjusted dynamically at each iteration c to accelerate convergence and prevent stagnation. c This is also roughly equal to the number of matrix-vector c products (involving the operator OP) per Arnoldi iteration. c The logic for adjusting is contained within the current c subroutine. c If ISHIFT=0, NP is the number of shifts the user needs c to provide via reverse comunication. 0 < NP < NCV-NEV. c NP may be less than NCV-NEV since a leading block of the current c upper Hessenberg matrix has split off and contains "unwanted" c Ritz values. c Upon termination of the IRA iteration, NP contains the number c of "converged" wanted Ritz values. c c IUPD Integer. (INPUT) c IUPD .EQ. 0: use explicit restart instead implicit update. c IUPD .NE. 0: use implicit update. c c V Complex*16 N by (NEV+NP) array. (INPUT/OUTPUT) c The Arnoldi basis vectors are returned in the first NEV c columns of V. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c H Complex*16 (NEV+NP) by (NEV+NP) array. (OUTPUT) c H is used to store the generated upper Hessenberg matrix c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Complex*16 array of length NEV+NP. (OUTPUT) c RITZ(1:NEV) contains the computed Ritz values of OP. c c BOUNDS Complex*16 array of length NEV+NP. (OUTPUT) c BOUNDS(1:NEV) contain the error bounds corresponding to c the computed Ritz values. c c Q Complex*16 (NEV+NP) by (NEV+NP) array. (WORKSPACE) c Private (replicated) work array used to accumulate the c rotation in the shift application step. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex*16 work array of length at least c (NEV+NP)**2 + 3*(NEV+NP). (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. It is used in shifts calculation, shifts c application and convergence checking. c c c IPNTR Integer array of length 3. (OUTPUT) c Pointer to mark the starting locations in the WORKD for c vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X. c IPNTR(2): pointer to the current result vector Y. c IPNTR(3): pointer to the vector B * X when used in the c shift-and-invert mode. X is the current operand. c ------------------------------------------------------------- c c WORKD Complex*16 work array of length 3*N. (WORKSPACE) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note in ZNAUPD . c c RWORK Double precision work array of length NEV+NP ( WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal return. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. c NP returns the number of converged Ritz values. c = 2: No shifts could be applied. c = -8: Error return from LAPACK eigenvalue calculation; c This should never happen. c = -9: Starting vector is zero. c = -9999: Could not build an Arnoldi factorization. c Size that was built in returned in NP. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c c\Routines called: c zgetv0 ARPACK initial vector generation routine. c znaitr ARPACK Arnoldi factorization routine. c znapps ARPACK application of implicit shifts routine. c zneigh ARPACK compute Ritz values and error bounds routine. c zngets ARPACK reorder Ritz values and error bounds routine. c zsortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c dvout ARPACK utility routine that prints vectors. c dlamch LAPACK routine that determines machine constants. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zcopy Level 1 BLAS that copies one vector to another . c zdotc Level 1 BLAS that computes the scalar product of two vectors. c zswap Level 1 BLAS that swaps two vectors. c dznrm2 Level 1 BLAS that computes the norm of a vector. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice Universitya c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naup2.F SID: 2.6 DATE OF SID: 06/01/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c subroutine znaup2 & ( ido, bmat, n, which, nev, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, h, ldh, ritz, bounds, & q, ldq, workl, ipntr, workd, rwork, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ishift, iupd, mode, ldh, ldq, ldv, mxiter, & n, nev, np Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer ipntr(13) Complex*16 & bounds(nev+np), h(ldh,nev+np), q(ldq,nev+np), & resid(n), ritz(nev+np), v(ldv,nev+np), & workd(3*n), workl( (nev+np)*(nev+np+3) ) Double precision & rwork(nev+np) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rzero parameter (one = (1.0D+0, 0.0D+0) , zero = (0.0D+0, 0.0D+0) , & rzero = 0.0D+0 ) c c %---------------% c | Local Scalars | c %---------------% c logical cnorm , getv0, initv , update, ushift integer ierr , iter , kplusp, msglvl, nconv, & nevbef, nev0 , np0 , nptemp, i , & j Complex*16 & cmpnorm Double precision & rnorm , eps23, rtemp character wprime*2 c save cnorm, getv0, initv , update, ushift, & rnorm, iter , kplusp, msglvl, nconv , & nevbef, nev0 , np0 , eps23 c c c %-----------------------% c | Local array arguments | c %-----------------------% c integer kp(3) c c %----------------------% c | External Subroutines | c %----------------------% c external zcopy , zgetv0 , znaitr , zneigh , zngets , znapps , & zsortc , zswap , zmout , zvout , ivout, arscnd c c %--------------------% c | External functions | c %--------------------% c Complex*16 & zdotc Double precision & dznrm2 , dlamch , dlapy2 external zdotc , dznrm2 , dlamch , dlapy2 c c %---------------------% c | Intrinsic Functions | c %---------------------% c intrinsic dimag , dble , min, max c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c call arscnd (t0) c msglvl = mcaup2 c nev0 = nev np0 = np c c %-------------------------------------% c | kplusp is the bound on the largest | c | Lanczos factorization built. | c | nconv is the current number of | c | "converged" eigenvalues. | c | iter is the counter on the current | c | iteration step. | c %-------------------------------------% c kplusp = nev + np nconv = 0 iter = 0 c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = dlamch ('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0 ) c c %---------------------------------------% c | Set flags for computing the first NEV | c | steps of the Arnoldi factorization. | c %---------------------------------------% c getv0 = .true. update = .false. ushift = .false. cnorm = .false. c if (info .ne. 0) then c c %--------------------------------------------% c | User provides the initial residual vector. | c %--------------------------------------------% c initv = .true. info = 0 else initv = .false. end if end if c c %---------------------------------------------% c | Get a possibly random starting vector and | c | force it into the range of the operator OP. | c %---------------------------------------------% c 10 continue c if (getv0) then call zgetv0 (ido, bmat, 1, initv, n, 1, v, ldv, resid, rnorm, & ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (rnorm .eq. rzero) then c c %-----------------------------------------% c | The initial vector is zero. Error exit. | c %-----------------------------------------% c info = -9 go to 1100 end if getv0 = .false. ido = 0 end if c c %-----------------------------------% c | Back from reverse communication : | c | continue with update step | c %-----------------------------------% c if (update) go to 20 c c %-------------------------------------------% c | Back from computing user specified shifts | c %-------------------------------------------% c if (ushift) go to 50 c c %-------------------------------------% c | Back from computing residual norm | c | at the end of the current iteration | c %-------------------------------------% c if (cnorm) go to 100 c c %----------------------------------------------------------% c | Compute the first NEV steps of the Arnoldi factorization | c %----------------------------------------------------------% c call znaitr (ido, bmat, n, 0, nev, mode, resid, rnorm, v, ldv, & h, ldh, ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if c c %--------------------------------------------------------------% c | | c | M A I N ARNOLDI I T E R A T I O N L O O P | c | Each iteration implicitly restarts the Arnoldi | c | factorization in place. | c | | c %--------------------------------------------------------------% c 1000 continue c iter = iter + 1 c if (msglvl .gt. 0) then call ivout (logfil, 1, iter, ndigit, & '_naup2: **** Start of major iteration number ****') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c | Adjust NP since NEV might have been updated by last call | c | to the shift application routine znapps . | c %-----------------------------------------------------------% c np = kplusp - nev c if (msglvl .gt. 1) then call ivout (logfil, 1, nev, ndigit, & '_naup2: The length of the current Arnoldi factorization') call ivout (logfil, 1, np, ndigit, & '_naup2: Extend the Arnoldi factorization by') end if c c %-----------------------------------------------------------% c | Compute NP additional steps of the Arnoldi factorization. | c %-----------------------------------------------------------% c ido = 0 20 continue update = .true. c call znaitr (ido, bmat, n, nev, np, mode, resid, rnorm, & v , ldv , h, ldh, ipntr, workd, info) c if (ido .ne. 99) go to 9000 c if (info .gt. 0) then np = info mxiter = iter info = -9999 go to 1200 end if update = .false. c if (msglvl .gt. 1) then call dvout (logfil, 1, rnorm, ndigit, & '_naup2: Corresponding B-norm of the residual') end if c c %--------------------------------------------------------% c | Compute the eigenvalues and corresponding error bounds | c | of the current upper Hessenberg matrix. | c %--------------------------------------------------------% c call zneigh (rnorm, kplusp, h, ldh, ritz, bounds, & q, ldq, workl, rwork, ierr) c if (ierr .ne. 0) then info = -8 go to 1200 end if c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | error bounds are in the last NEV loc. of RITZ, | c | and BOUNDS respectively. | c %---------------------------------------------------% c nev = nev0 np = np0 c c %--------------------------------------------------% c | Make a copy of Ritz values and the corresponding | c | Ritz estimates obtained from zneigh . | c %--------------------------------------------------% c call zcopy (kplusp,ritz,1,workl(kplusp**2+1),1) call zcopy (kplusp,bounds,1,workl(kplusp**2+kplusp+1),1) c c %---------------------------------------------------% c | Select the wanted Ritz values and their bounds | c | to be used in the convergence test. | c | The wanted part of the spectrum and corresponding | c | bounds are in the last NEV loc. of RITZ | c | BOUNDS respectively. | c %---------------------------------------------------% c call zngets (ishift, which, nev, np, ritz, bounds) c c %------------------------------------------------------------% c | Convergence test: currently we use the following criteria. | c | The relative accuracy of a Ritz value is considered | c | acceptable if: | c | | c | error_bounds(i) .le. tol*max(eps23, magnitude_of_ritz(i)). | c | | c %------------------------------------------------------------% c nconv = 0 c do 25 i = 1, nev rtemp = max( eps23, dlapy2 ( dble (ritz(np+i)), & dimag (ritz(np+i)) ) ) if ( dlapy2 (dble (bounds(np+i)),dimag (bounds(np+i))) & .le. tol*rtemp ) then nconv = nconv + 1 end if 25 continue c if (msglvl .gt. 2) then kp(1) = nev kp(2) = np kp(3) = nconv call ivout (logfil, 3, kp, ndigit, & '_naup2: NEV, NP, NCONV are') call zvout (logfil, kplusp, ritz, ndigit, & '_naup2: The eigenvalues of H') call zvout (logfil, kplusp, bounds, ndigit, & '_naup2: Ritz estimates of the current NCV Ritz values') end if c c %---------------------------------------------------------% c | Count the number of unwanted Ritz values that have zero | c | Ritz estimates. If any Ritz estimates are equal to zero | c | then a leading block of H of order equal to at least | c | the number of Ritz values with zero Ritz estimates has | c | split off. None of these Ritz values may be removed by | c | shifting. Decrease NP the number of shifts to apply. If | c | no shifts may be applied, then prepare to exit | c %---------------------------------------------------------% c nptemp = np do 30 j=1, nptemp if (bounds(j) .eq. zero) then np = np - 1 nev = nev + 1 end if 30 continue c if ( (nconv .ge. nev0) .or. & (iter .gt. mxiter) .or. & (np .eq. 0) ) then c if (msglvl .gt. 4) then call zvout (logfil, kplusp, workl(kplusp**2+1), ndigit, & '_naup2: Eigenvalues computed by _neigh:') call zvout (logfil, kplusp, workl(kplusp**2+kplusp+1), & ndigit, & '_naup2: Ritz estimates computed by _neigh:') end if c c %------------------------------------------------% c | Prepare to exit. Put the converged Ritz values | c | and corresponding bounds in RITZ(1:NCONV) and | c | BOUNDS(1:NCONV) respectively. Then sort. Be | c | careful when NCONV > NP | c %------------------------------------------------% c c %------------------------------------------% c | Use h( 3,1 ) as storage to communicate | c | rnorm to zneupd if needed | c %------------------------------------------% h(3,1) = dcmplx (rnorm,rzero) c c %----------------------------------------------% c | Sort Ritz values so that converged Ritz | c | values appear within the first NEV locations | c | of ritz and bounds, and the most desired one | c | appears at the front. | c %----------------------------------------------% c if (which .eq. 'LM') wprime = 'SM' if (which .eq. 'SM') wprime = 'LM' if (which .eq. 'LR') wprime = 'SR' if (which .eq. 'SR') wprime = 'LR' if (which .eq. 'LI') wprime = 'SI' if (which .eq. 'SI') wprime = 'LI' c call zsortc (wprime, .true., kplusp, ritz, bounds) c c %--------------------------------------------------% c | Scale the Ritz estimate of each Ritz value | c | by 1 / max(eps23, magnitude of the Ritz value). | c %--------------------------------------------------% c do 35 j = 1, nev0 rtemp = max( eps23, dlapy2 ( dble (ritz(j)), & dimag (ritz(j)) ) ) bounds(j) = bounds(j)/rtemp 35 continue c c %---------------------------------------------------% c | Sort the Ritz values according to the scaled Ritz | c | estimates. This will push all the converged ones | c | towards the front of ritz, bounds (in the case | c | when NCONV < NEV.) | c %---------------------------------------------------% c wprime = 'LM' call zsortc (wprime, .true., nev0, bounds, ritz) c c %----------------------------------------------% c | Scale the Ritz estimate back to its original | c | value. | c %----------------------------------------------% c do 40 j = 1, nev0 rtemp = max( eps23, dlapy2 ( dble (ritz(j)), & dimag (ritz(j)) ) ) bounds(j) = bounds(j)*rtemp 40 continue c c %-----------------------------------------------% c | Sort the converged Ritz values again so that | c | the "threshold" value appears at the front of | c | ritz and bound. | c %-----------------------------------------------% c call zsortc (which, .true., nconv, ritz, bounds) c if (msglvl .gt. 1) then call zvout (logfil, kplusp, ritz, ndigit, & '_naup2: Sorted eigenvalues') call zvout (logfil, kplusp, bounds, ndigit, & '_naup2: Sorted ritz estimates.') end if c c %------------------------------------% c | Max iterations have been exceeded. | c %------------------------------------% c if (iter .gt. mxiter .and. nconv .lt. nev0) info = 1 c c %---------------------% c | No shifts to apply. | c %---------------------% c if (np .eq. 0 .and. nconv .lt. nev0) info = 2 c np = nconv go to 1100 c else if ( (nconv .lt. nev0) .and. (ishift .eq. 1) ) then c c %-------------------------------------------------% c | Do not have all the requested eigenvalues yet. | c | To prevent possible stagnation, adjust the size | c | of NEV. | c %-------------------------------------------------% c nevbef = nev nev = nev + min(nconv, np/2) if (nev .eq. 1 .and. kplusp .ge. 6) then nev = kplusp / 2 else if (nev .eq. 1 .and. kplusp .gt. 3) then nev = 2 end if np = kplusp - nev c c %---------------------------------------% c | If the size of NEV was just increased | c | resort the eigenvalues. | c %---------------------------------------% c if (nevbef .lt. nev) & call zngets (ishift, which, nev, np, ritz, bounds) c end if c if (msglvl .gt. 0) then call ivout (logfil, 1, nconv, ndigit, & '_naup2: no. of "converged" Ritz values at this iter.') if (msglvl .gt. 1) then kp(1) = nev kp(2) = np call ivout (logfil, 2, kp, ndigit, & '_naup2: NEV and NP are') call zvout (logfil, nev, ritz(np+1), ndigit, & '_naup2: "wanted" Ritz values ') call zvout (logfil, nev, bounds(np+1), ndigit, & '_naup2: Ritz estimates of the "wanted" values ') end if end if c if (ishift .eq. 0) then c c %-------------------------------------------------------% c | User specified shifts: pop back out to get the shifts | c | and return them in the first 2*NP locations of WORKL. | c %-------------------------------------------------------% c ushift = .true. ido = 3 go to 9000 end if 50 continue ushift = .false. c if ( ishift .ne. 1 ) then c c %----------------------------------% c | Move the NP shifts from WORKL to | c | RITZ, to free up WORKL | c | for non-exact shift case. | c %----------------------------------% c call zcopy (np, workl, 1, ritz, 1) end if c if (msglvl .gt. 2) then call ivout (logfil, 1, np, ndigit, & '_naup2: The number of shifts to apply ') call zvout (logfil, np, ritz, ndigit, & '_naup2: values of the shifts') if ( ishift .eq. 1 ) & call zvout (logfil, np, bounds, ndigit, & '_naup2: Ritz estimates of the shifts') end if c c %---------------------------------------------------------% c | Apply the NP implicit shifts by QR bulge chasing. | c | Each shift is applied to the whole upper Hessenberg | c | matrix H. | c | The first 2*N locations of WORKD are used as workspace. | c %---------------------------------------------------------% c call znapps (n, nev, np, ritz, v, ldv, & h, ldh, resid, q, ldq, workl, workd) c c %---------------------------------------------% c | Compute the B-norm of the updated residual. | c | Keep B*RESID in WORKD(1:N) to be used in | c | the first step of the next call to znaitr . | c %---------------------------------------------% c cnorm = .true. call arscnd (t2) if (bmat .eq. 'G') then nbx = nbx + 1 call zcopy (n, resid, 1, workd(n+1), 1) ipntr(1) = n + 1 ipntr(2) = 1 ido = 2 c c %----------------------------------% c | Exit in order to compute B*RESID | c %----------------------------------% c go to 9000 else if (bmat .eq. 'I') then call zcopy (n, resid, 1, workd, 1) end if c 100 continue c c %----------------------------------% c | Back from reverse communication; | c | WORKD(1:N) := B*RESID | c %----------------------------------% c if (bmat .eq. 'G') then call arscnd (t3) tmvbx = tmvbx + (t3 - t2) end if c if (bmat .eq. 'G') then cmpnorm = zdotc (n, resid, 1, workd, 1) rnorm = sqrt(dlapy2 (dble (cmpnorm),dimag (cmpnorm))) else if (bmat .eq. 'I') then rnorm = dznrm2 (n, resid, 1) end if cnorm = .false. c if (msglvl .gt. 2) then call dvout (logfil, 1, rnorm, ndigit, & '_naup2: B-norm of residual for compressed factorization') call zmout (logfil, nev, nev, h, ldh, ndigit, & '_naup2: Compressed upper Hessenberg matrix H') end if c go to 1000 c c %---------------------------------------------------------------% c | | c | E N D O F M A I N I T E R A T I O N L O O P | c | | c %---------------------------------------------------------------% c 1100 continue c mxiter = iter nev = nconv c 1200 continue ido = 99 c c %------------% c | Error Exit | c %------------% c call arscnd (t1) tcaup2 = t1 - t0 c 9000 continue c c %---------------% c | End of znaup2 | c %---------------% c return end arpack-akloeckner-07/SRC/znaupd.f0000644000175000017500000006631510670622032016603 0ustar andreasandreasc\BeginDoc c c\Name: znaupd c c\Description: c Reverse communication interface for the Implicitly Restarted Arnoldi c iteration. This is intended to be used to find a few eigenpairs of a c complex linear operator OP with respect to a semi-inner product defined c by a hermitian positive semi-definite real matrix B. B may be the identity c matrix. NOTE: if both OP and B are real, then dsaupd or dnaupd should c be used. c c c The computed approximate eigenvalues are called Ritz values and c the corresponding approximate eigenvectors are called Ritz vectors. c c znaupd is usually called iteratively to solve one of the c following problems: c c Mode 1: A*x = lambda*x. c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, M hermitian positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 below) c c Mode 3: A*x = lambda*M*x, M hermitian semi-definite c ===> OP = inv[A - sigma*M]*M and B = M. c ===> shift-and-invert mode c If OP*x = amu*x, then lambda = sigma + 1/amu. c c c NOTE: The action of w <- inv[A - sigma*M]*v or w <- inv[M]*v c should be accomplished either by a direct method c using a sparse matrix factorization and solving c c [A - sigma*M]*w = v or M*w = v, c c or through an iterative method for solving these c systems. If an iterative method is used, the c convergence test must be more stringent than c the accuracy requirements for the eigenvalue c approximations. c c\Usage: c call znaupd c ( IDO, BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, c IPNTR, WORKD, WORKL, LWORKL, RWORK, INFO ) c c\Arguments c IDO Integer. (INPUT/OUTPUT) c Reverse communication flag. IDO must be zero on the first c call to znaupd. IDO will be set internally to c indicate the type of operation to be performed. Control is c then given back to the calling routine which has the c responsibility to carry out the requested operation and call c znaupd with the result. The operand is given in c WORKD(IPNTR(1)), the result must be put in WORKD(IPNTR(2)). c ------------------------------------------------------------- c IDO = 0: first call to the reverse communication interface c IDO = -1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c This is for the initialization phase to force the c starting vector into the range of OP. c IDO = 1: compute Y = OP * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c In mode 3, the vector B * X is already c available in WORKD(ipntr(3)). It does not c need to be recomputed in forming OP * X. c IDO = 2: compute Y = M * X where c IPNTR(1) is the pointer into WORKD for X, c IPNTR(2) is the pointer into WORKD for Y. c IDO = 3: compute and return the shifts in the first c NP locations of WORKL. c IDO = 99: done c ------------------------------------------------------------- c After the initialization phase, when the routine is used in c the "shift-and-invert" mode, the vector M * X is already c available and does not need to be recomputed in forming OP*X. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c c N Integer. (INPUT) c Dimension of the eigenproblem. c c WHICH Character*2. (INPUT) c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. 0 < NEV < N-1. c c TOL Double precision scalar. (INPUT) c Stopping criteria: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = dlamch('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine dlamch). c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 1 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. (See remark 4 below.) c c V Complex*16 array N by NCV. (OUTPUT) c Contains the final set of Arnoldi basis vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: method for selecting the implicit shifts. c The shifts selected at each iteration are used to filter out c the components of the unwanted eigenvector. c ------------------------------------------------------------- c ISHIFT = 0: the shifts are to be provided by the user via c reverse communication. The NCV eigenvalues of c the Hessenberg matrix H are returned in the part c of WORKL array corresponding to RITZ. c ISHIFT = 1: exact shifts with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration from the beginning c after updating the starting vector with a linear c combination of Ritz vectors associated with the c "wanted" eigenvalues. c ISHIFT = 2: other choice of internal shift to be defined. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced c c IPARAM(3) = MXITER c On INPUT: maximum number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" Ritz values. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3; See under \Description of znaupd for the c four modes available. c c IPARAM(8) = NP c When ido = 3 and the user provides shifts through reverse c communication (IPARAM(1)=0), _naupd returns NP, the number c of shifts the user is to provide. 0 < NP < NCV-NEV. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c IPNTR Integer array of length 14. (OUTPUT) c Pointer to mark the starting locations in the WORKD and WORKL c arrays for matrices/vectors used by the Arnoldi iteration. c ------------------------------------------------------------- c IPNTR(1): pointer to the current operand vector X in WORKD. c IPNTR(2): pointer to the current result vector Y in WORKD. c IPNTR(3): pointer to the vector B * X in WORKD when used in c the shift-and-invert mode. c IPNTR(4): pointer to the next available location in WORKL c that is untouched by the program. c IPNTR(5): pointer to the NCV by NCV upper Hessenberg c matrix H in WORKL. c IPNTR(6): pointer to the ritz value array RITZ c IPNTR(7): pointer to the (projected) ritz vector array Q c IPNTR(8): pointer to the error BOUNDS array in WORKL. c IPNTR(14): pointer to the NP shifts in WORKL. See Remark 5 below. c c Note: IPNTR(9:13) is only referenced by zneupd. See Remark 2 below. c c IPNTR(9): pointer to the NCV RITZ values of the c original system. c IPNTR(10): Not Used c IPNTR(11): pointer to the NCV corresponding error bounds. c IPNTR(12): pointer to the NCV by NCV upper triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c zneupd if RVEC = .TRUE. See Remark 2 below. c c ------------------------------------------------------------- c c WORKD Complex*16 work array of length 3*N. (REVERSE COMMUNICATION) c Distributed array to be used in the basic Arnoldi iteration c for reverse communication. The user should not use WORKD c as temporary workspace during the iteration !!!!!!!!!! c See Data Distribution Note below. c c WORKL Complex*16 work array of length LWORKL. (OUTPUT/WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. See Data Distribution Note below. c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 5*NCV. c c RWORK Double precision work array of length NCV (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c c INFO Integer. (INPUT/OUTPUT) c If INFO .EQ. 0, a randomly initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 2: No longer an informational error. Deprecated starting c with release 2 of ARPACK. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 below. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 1 and less than or equal to N. c = -4: The maximum number of Arnoldi update iteration c must be greater than zero. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation; c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: IPARAM(1) must be equal to 0 or 1. c = -9999: Could not build an Arnoldi factorization. c User input error highly likely. Please c check actual array dimensions and layout. c IPARAM(5) returns the size of the current Arnoldi c factorization. c c\Remarks c 1. The computed Ritz values are approximate eigenvalues of OP. The c selection of WHICH should be made with this in mind when using c Mode = 3. When operating in Mode = 3 setting WHICH = 'LM' will c compute the NEV eigenvalues of the original problem that are c closest to the shift SIGMA . After convergence, approximate eigenvalues c of the original problem may be obtained with the ARPACK subroutine zneupd. c c 2. If a basis for the invariant subspace corresponding to the converged Ritz c values is needed, the user must call zneupd immediately following c completion of znaupd. This is new starting with release 2 of ARPACK. c c 3. If M can be factored into a Cholesky factorization M = LL` c then Mode = 2 should not be selected. Instead one should use c Mode = 1 with OP = inv(L)*A*inv(L`). Appropriate triangular c linear systems should be solved with L and L` rather c than computing inverses. After convergence, an approximate c eigenvector z of the original problem is recovered by solving c L`z = x where x is a Ritz vector of OP. c c 4. At present there is no a-priori analysis to guide the selection c of NCV relative to NEV. The only formal requirement is that NCV > NEV + 1. c However, it is recommended that NCV .ge. 2*NEV. If many problems of c the same type are to be solved, one should experiment with increasing c NCV while keeping NEV fixed for a given test problem. This will c usually decrease the required number of OP*x operations but it c also increases the work and storage required to maintain the orthogonal c basis vectors. The optimal "cross-over" with respect to CPU time c is problem dependent and must be determined empirically. c See Chapter 8 of Reference 2 for further information. c c 5. When IPARAM(1) = 0, and IDO = 3, the user needs to provide the c NP = IPARAM(8) complex shifts in locations c WORKL(IPNTR(14)), WORKL(IPNTR(14)+1), ... , WORKL(IPNTR(14)+NP). c Eigenvalues of the current upper Hessenberg matrix are located in c WORKL(IPNTR(6)) through WORKL(IPNTR(6)+NCV-1). They are ordered c according to the order defined by WHICH. The associated Ritz estimates c are located in WORKL(IPNTR(8)), WORKL(IPNTR(8)+1), ... , c WORKL(IPNTR(8)+NCV-1). c c----------------------------------------------------------------------- c c\Data Distribution Note: c c Fortran-D syntax: c ================ c Complex*16 resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) c decompose d1(n), d2(n,ncv) c align resid(i) with d1(i) c align v(i,j) with d2(i,j) c align workd(i) with d1(i) range (1:n) c align workd(i) with d1(i-n) range (n+1:2*n) c align workd(i) with d1(i-2*n) range (2*n+1:3*n) c distribute d1(block), d2(block,:) c replicated workl(lworkl) c c Cray MPP syntax: c =============== c Complex*16 resid(n), v(ldv,ncv), workd(n,3), workl(lworkl) c shared resid(block), v(block,:), workd(block,:) c replicated workl(lworkl) c c CM2/CM5 syntax: c ============== c c----------------------------------------------------------------------- c c include 'ex-nonsym.doc' c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B.N. Parlett & Y. Saad, "_Complex_ Shift and Invert Strategies for c Double precision Matrices", Linear Algebra and its Applications, vol 88/89, c pp 575-595, (1987). c c\Routines called: c znaup2 ARPACK routine that implements the Implicitly Restarted c Arnoldi Iteration. c zstatn ARPACK routine that initializes the timing variables. c ivout ARPACK utility routine that prints integers. c zvout ARPACK utility routine that prints vectors. c arscnd ARPACK utility routine for timing. c dlamch LAPACK routine that determines machine constants. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: naupd.F SID: 2.9 DATE OF SID: 07/21/02 RELEASE: 2 c c\Remarks c c\EndLib c c----------------------------------------------------------------------- c subroutine znaupd & ( ido, bmat, n, which, nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, rwork, info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat*1, which*2 integer ido, info, ldv, lworkl, n, ncv, nev Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) Complex*16 & resid(n), v(ldv,ncv), workd(3*n), workl(lworkl) Double precision & rwork(ncv) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) c c %---------------% c | Local Scalars | c %---------------% c integer bounds, ierr, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritz, j save bounds, ih, iq, ishift, iupd, iw, & ldh, ldq, levec, mode, msglvl, mxiter, nb, & nev0, next, np, ritz c c %----------------------% c | External Subroutines | c %----------------------% c external znaup2, zvout, ivout, arscnd, zstatn c c %--------------------% c | External Functions | c %--------------------% c Double precision & dlamch external dlamch c c %-----------------------% c | Executable Statements | c %-----------------------% c if (ido .eq. 0) then c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call zstatn call arscnd (t0) msglvl = mcaupd c c %----------------% c | Error checking | c %----------------% c ierr = 0 ishift = iparam(1) c levec = iparam(2) mxiter = iparam(3) c nb = iparam(4) nb = 1 c c %--------------------------------------------% c | Revision 2 performs only implicit restart. | c %--------------------------------------------% c iupd = 1 mode = iparam(7) c if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 else if (mxiter .le. 0) then ierr = -4 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 5*ncv) then ierr = -7 else if (mode .lt. 1 .or. mode .gt. 3) then ierr = -10 else if (mode .eq. 1 .and. bmat .eq. 'G') then ierr = -11 end if c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr ido = 99 go to 9000 end if c c %------------------------% c | Set default parameters | c %------------------------% c if (nb .le. 0) nb = 1 if (tol .le. 0.0D+0 ) tol = dlamch('EpsMach') if (ishift .ne. 0 .and. & ishift .ne. 1 .and. & ishift .ne. 2) ishift = 1 c c %----------------------------------------------% c | NP is the number of additional steps to | c | extend the length NEV Lanczos factorization. | c | NEV0 is the local variable designating the | c | size of the invariant subspace desired. | c %----------------------------------------------% c np = ncv - nev nev0 = nev c c %-----------------------------% c | Zero out internal workspace | c %-----------------------------% c do 10 j = 1, 3*ncv**2 + 5*ncv workl(j) = zero 10 continue c c %-------------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, BOUNDS, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+ncv) := the ritz values | c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | c | workl(ncv*ncv+2*ncv+1:2*ncv*ncv+2*ncv) := rotation matrix Q | c | workl(2*ncv*ncv+2*ncv+1:3*ncv*ncv+5*ncv) := workspace | c | The final workspace is needed by subroutine zneigh called | c | by znaup2. Subroutine zneigh calls LAPACK routines for | c | calculating eigenvalues and the last row of the eigenvector | c | matrix. | c %-------------------------------------------------------------% c ldh = ncv ldq = ncv ih = 1 ritz = ih + ldh*ncv bounds = ritz + ncv iq = bounds + ncv iw = iq + ldq*ncv next = iw + ncv**2 + 3*ncv c ipntr(4) = next ipntr(5) = ih ipntr(6) = ritz ipntr(7) = iq ipntr(8) = bounds ipntr(14) = iw end if c c %-------------------------------------------------------% c | Carry out the Implicitly restarted Arnoldi Iteration. | c %-------------------------------------------------------% c call znaup2 & ( ido, bmat, n, which, nev0, np, tol, resid, mode, iupd, & ishift, mxiter, v, ldv, workl(ih), ldh, workl(ritz), & workl(bounds), workl(iq), ldq, workl(iw), & ipntr, workd, rwork, info ) c c %--------------------------------------------------% c | ido .ne. 99 implies use of reverse communication | c | to compute operations involving OP. | c %--------------------------------------------------% c if (ido .eq. 3) iparam(8) = np if (ido .ne. 99) go to 9000 c iparam(3) = mxiter iparam(5) = np iparam(9) = nopx iparam(10) = nbx iparam(11) = nrorth c c %------------------------------------% c | Exit if there was an informational | c | error within znaup2. | c %------------------------------------% c if (info .lt. 0) go to 9000 if (info .eq. 2) info = 3 c if (msglvl .gt. 0) then call ivout (logfil, 1, mxiter, ndigit, & '_naupd: Number of update iterations taken') call ivout (logfil, 1, np, ndigit, & '_naupd: Number of wanted "converged" Ritz values') call zvout (logfil, np, workl(ritz), ndigit, & '_naupd: The final Ritz values') call zvout (logfil, np, workl(bounds), ndigit, & '_naupd: Associated Ritz estimates') end if c call arscnd (t1) tcaupd = t1 - t0 c if (msglvl .gt. 0) then c c %--------------------------------------------------------% c | Version Number & Version Date are defined in version.h | c %--------------------------------------------------------% c write (6,1000) write (6,1100) mxiter, nopx, nbx, nrorth, nitref, nrstrt, & tmvopx, tmvbx, tcaupd, tcaup2, tcaitr, titref, & tgetv0, tceigh, tcgets, tcapps, tcconv, trvec 1000 format (//, & 5x, '=============================================',/ & 5x, '= Complex implicit Arnoldi update code =',/ & 5x, '= Version Number: ', ' 2.3', 21x, ' =',/ & 5x, '= Version Date: ', ' 07/31/96', 16x, ' =',/ & 5x, '=============================================',/ & 5x, '= Summary of timing statistics =',/ & 5x, '=============================================',//) 1100 format ( & 5x, 'Total number update iterations = ', i5,/ & 5x, 'Total number of OP*x operations = ', i5,/ & 5x, 'Total number of B*x operations = ', i5,/ & 5x, 'Total number of reorthogonalization steps = ', i5,/ & 5x, 'Total number of iterative refinement steps = ', i5,/ & 5x, 'Total number of restart steps = ', i5,/ & 5x, 'Total time in user OP*x operation = ', f12.6,/ & 5x, 'Total time in user B*x operation = ', f12.6,/ & 5x, 'Total time in Arnoldi update routine = ', f12.6,/ & 5x, 'Total time in naup2 routine = ', f12.6,/ & 5x, 'Total time in basic Arnoldi iteration loop = ', f12.6,/ & 5x, 'Total time in reorthogonalization phase = ', f12.6,/ & 5x, 'Total time in (re)start vector generation = ', f12.6,/ & 5x, 'Total time in Hessenberg eig. subproblem = ', f12.6,/ & 5x, 'Total time in getting the shifts = ', f12.6,/ & 5x, 'Total time in applying the shifts = ', f12.6,/ & 5x, 'Total time in convergence testing = ', f12.6,/ & 5x, 'Total time in computing final Ritz vectors = ', f12.6/) end if c 9000 continue c return c c %---------------% c | End of znaupd | c %---------------% c end arpack-akloeckner-07/SRC/zneigh.f0000644000175000017500000002007010670622032016552 0ustar andreasandreasc\BeginDoc c c\Name: zneigh c c\Description: c Compute the eigenvalues of the current upper Hessenberg matrix c and the corresponding Ritz estimates given the current residual norm. c c\Usage: c call zneigh c ( RNORM, N, H, LDH, RITZ, BOUNDS, Q, LDQ, WORKL, RWORK, IERR ) c c\Arguments c RNORM Double precision scalar. (INPUT) c Residual norm corresponding to the current upper Hessenberg c matrix H. c c N Integer. (INPUT) c Size of the matrix H. c c H Complex*16 N by N array. (INPUT) c H contains the current upper Hessenberg matrix. c c LDH Integer. (INPUT) c Leading dimension of H exactly as declared in the calling c program. c c RITZ Complex*16 array of length N. (OUTPUT) c On output, RITZ(1:N) contains the eigenvalues of H. c c BOUNDS Complex*16 array of length N. (OUTPUT) c On output, BOUNDS contains the Ritz estimates associated with c the eigenvalues held in RITZ. This is equal to RNORM c times the last components of the eigenvectors corresponding c to the eigenvalues in RITZ. c c Q Complex*16 N by N array. (WORKSPACE) c Workspace needed to store the eigenvectors of H. c c LDQ Integer. (INPUT) c Leading dimension of Q exactly as declared in the calling c program. c c WORKL Complex*16 work array of length N**2 + 3*N. (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. This is needed to keep the full Schur form c of H and also in the calculation of the eigenvectors of H. c c RWORK Double precision work array of length N (WORKSPACE) c Private (replicated) array on each PE or array allocated on c the front end. c c IERR Integer. (OUTPUT) c Error exit flag from zlahqr or ztrevc. c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\Routines called: c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c dvout ARPACK utility routine that prints vectors. c zlacpy LAPACK matrix copy routine. c zlahqr LAPACK routine to compute the Schur form of an c upper Hessenberg matrix. c zlaset LAPACK matrix initialization routine. c ztrevc LAPACK routine to compute the eigenvectors of a matrix c in upper triangular form c zcopy Level 1 BLAS that copies one vector to another. c zdscal Level 1 BLAS that scales a complex vector by a real number. c dznrm2 Level 1 BLAS that computes the norm of a vector. c c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neigh.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c None c c\EndLib c c----------------------------------------------------------------------- c subroutine zneigh (rnorm, n, h, ldh, ritz, bounds, & q, ldq, workl, rwork, ierr) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c integer ierr, n, ldh, ldq Double precision & rnorm c c %-----------------% c | Array Arguments | c %-----------------% c Complex*16 & bounds(n), h(ldh,n), q(ldq,n), ritz(n), & workl(n*(n+3)) Double precision & rwork(n) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero Double precision & rone parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0), & rone = 1.0D+0) c c %------------------------% c | Local Scalars & Arrays | c %------------------------% c logical select(1) integer j, msglvl Complex*16 & vl(1) Double precision & temp c c %----------------------% c | External Subroutines | c %----------------------% c external zlacpy, zlahqr, ztrevc, zcopy, & zdscal, zmout, zvout, arscnd c c %--------------------% c | External Functions | c %--------------------% c Double precision & dznrm2 external dznrm2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mceigh c if (msglvl .gt. 2) then call zmout (logfil, n, n, h, ldh, ndigit, & '_neigh: Entering upper Hessenberg matrix H ') end if c c %----------------------------------------------------------% c | 1. Compute the eigenvalues, the last components of the | c | corresponding Schur vectors and the full Schur form T | c | of the current upper Hessenberg matrix H. | c | zlahqr returns the full Schur form of H | c | in WORKL(1:N**2), and the Schur vectors in q. | c %----------------------------------------------------------% c call zlacpy ('All', n, n, h, ldh, workl, n) call zlaset ('All', n, n, zero, one, q, ldq) call zlahqr (.true., .true., n, 1, n, workl, ldh, ritz, & 1, n, q, ldq, ierr) if (ierr .ne. 0) go to 9000 c call zcopy (n, q(n-1,1), ldq, bounds, 1) if (msglvl .gt. 1) then call zvout (logfil, n, bounds, ndigit, & '_neigh: last row of the Schur matrix for H') end if c c %----------------------------------------------------------% c | 2. Compute the eigenvectors of the full Schur form T and | c | apply the Schur vectors to get the corresponding | c | eigenvectors. | c %----------------------------------------------------------% c call ztrevc ('Right', 'Back', select, n, workl, n, vl, n, q, & ldq, n, n, workl(n*n+1), rwork, ierr) c if (ierr .ne. 0) go to 9000 c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | ztrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1; here the magnitude of a complex | c | number (x,y) is taken to be |x| + |y|. | c %------------------------------------------------% c do 10 j=1, n temp = dznrm2( n, q(1,j), 1 ) call zdscal ( n, rone / temp, q(1,j), 1 ) 10 continue c if (msglvl .gt. 1) then call zcopy(n, q(n,1), ldq, workl, 1) call zvout (logfil, n, workl, ndigit, & '_neigh: Last row of the eigenvector matrix for H') end if c c %----------------------------% c | Compute the Ritz estimates | c %----------------------------% c call zcopy(n, q(n,1), n, bounds, 1) call zdscal(n, rnorm, bounds, 1) c if (msglvl .gt. 2) then call zvout (logfil, n, ritz, ndigit, & '_neigh: The eigenvalues of H') call zvout (logfil, n, bounds, ndigit, & '_neigh: Ritz estimates for the eigenvalues of H') end if c call arscnd(t1) tceigh = tceigh + (t1 - t0) c 9000 continue return c c %---------------% c | End of zneigh | c %---------------% c end arpack-akloeckner-07/SRC/zneupd.f0000644000175000017500000010411007526640520016601 0ustar andreasandreasc\BeginDoc c c\Name: zneupd c c\Description: c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are derived from approximate eigenvalues and eigenvectors of c of the linear operator OP prescribed by the MODE selection in the c call to ZNAUPD. ZNAUPD must be called before this routine is called. c These approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c The definition of OP as well as other terms and the relation of computed c Ritz values and vectors of OP with respect to the given problem c A*z = lambda*B*z may be found in the header of ZNAUPD. For a brief c description, see definitions of IPARAM(7), MODE and WHICH in the c documentation of ZNAUPD. c c\Usage: c call zneupd c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, WORKEV, BMAT, c N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, WORKD, c WORKL, LWORKL, RWORK, INFO ) c c\Arguments: c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT need not be initialized c but it is used as internal workspace. c c D Complex*16 array of dimension NEV+1. (OUTPUT) c On exit, D contains the Ritz approximations c to the eigenvalues lambda for A*z = lambda*B*z. c c Z Complex*16 N by NEV array (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represents approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by ZNAUPD. In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ) is required. c In any case, LDZ .ge. 1 is required. c c SIGMA Complex*16 (INPUT) c If IPARAM(7) = 3 then SIGMA represents the shift. c Not referenced if IPARAM(7) = 1 or 2. c c WORKEV Complex*16 work array of dimension 2*NCV. (WORKSPACE) c c **** The remaining arguments MUST be the same as for the **** c **** call to ZNAUPD that was just completed. **** c c NOTE: The remaining arguments c c BMAT, N, WHICH, NEV, TOL, RESID, NCV, V, LDV, IPARAM, IPNTR, c WORKD, WORKL, LWORKL, RWORK, INFO c c must be passed directly to ZNEUPD following the last call c to ZNAUPD. These arguments MUST NOT BE MODIFIED between c the the last call to ZNAUPD and the call to ZNEUPD. c c Three of these parameters (V, WORKL and INFO) are also output parameters: c c V Complex*16 N by NCV array. (INPUT/OUTPUT) c c Upon INPUT: the NCV columns of V contain the Arnoldi basis c vectors for OP as constructed by ZNAUPD . c c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then the c Arnoldi basis held by V has been overwritten by the desired c Ritz vectors. If a separate array Z has been passed then c the first NCONV=IPARAM(5) columns of V will contain approximate c Schur vectors that span the desired invariant subspace. c c WORKL Double precision work array of length LWORKL. (OUTPUT/WORKSPACE) c WORKL(1:ncv*ncv+2*ncv) contains information obtained in c znaupd. They are not changed by zneupd. c WORKL(ncv*ncv+2*ncv+1:3*ncv*ncv+4*ncv) holds the c untransformed Ritz values, the untransformed error estimates of c the Ritz values, the upper triangular matrix for H, and the c associated matrix representation of the invariant subspace for H. c c Note: IPNTR(9:13) contains the pointer into WORKL for addresses c of the above information computed by zneupd. c ------------------------------------------------------------- c IPNTR(9): pointer to the NCV RITZ values of the c original system. c IPNTR(10): Not used c IPNTR(11): pointer to the NCV corresponding error estimates. c IPNTR(12): pointer to the NCV by NCV upper triangular c Schur matrix for H. c IPNTR(13): pointer to the NCV by NCV matrix of eigenvectors c of the upper Hessenberg matrix H. Only referenced by c zneupd if RVEC = .TRUE. See Remark 2 below. c ------------------------------------------------------------- c c INFO Integer. (OUTPUT) c Error flag on output. c = 0: Normal exit. c c = 1: The Schur form computed by LAPACK routine csheqr c could not be reordered by LAPACK routine ztrsen. c Re-enter subroutine zneupd with IPARAM(5)=NCV and c increase the size of the array D to have c dimension at least dimension NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors if this error c occurs. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 1 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation. c This should never happened. c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine ztrevc. c = -10: IPARAM(7) must be 1,2,3 c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: ZNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: ZNEUPD got a different count of the number of converged c Ritz values than ZNAUPD got. This indicates the user c probably made an error in passing data from ZNAUPD to c ZNEUPD or that the data was modified before entering c ZNEUPD c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Rice University Technical Report c TR95-13, Department of Computational and Applied Mathematics. c 3. B. Nour-Omid, B. N. Parlett, T. Ericsson and P. S. Jensen, c "How to Implement the Spectral Transformation", Math Comp., c Vol. 48, No. 178, April, 1987 pp. 664-673. c c\Routines called: c ivout ARPACK utility routine that prints integers. c zmout ARPACK utility routine that prints matrices c zvout ARPACK utility routine that prints vectors. c zgeqr2 LAPACK routine that computes the QR factorization of c a matrix. c zlacpy LAPACK matrix copy routine. c zlahqr LAPACK routine that computes the Schur form of a c upper Hessenberg matrix. c zlaset LAPACK matrix initialization routine. c ztrevc LAPACK routine to compute the eigenvectors of a matrix c in upper triangular form. c ztrsen LAPACK routine that re-orders the Schur form. c zunm2r LAPACK routine that applies an orthogonal matrix in c factored form. c dlamch LAPACK routine that determines machine constants. c ztrmm Level 3 BLAS matrix times an upper triangular matrix. c zgeru Level 2 BLAS rank one update to a matrix. c zcopy Level 1 BLAS that copies one vector to another . c zscal Level 1 BLAS that scales a vector. c zdscal Level 1 BLAS that scales a complex vector by a real number. c dznrm2 Level 1 BLAS that computes the norm of a complex vector. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .true. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c transpose( V(:,1:IPARAM(5)) ) * V(:,1:IPARAM(5)) = I c are approximately satisfied. c Here T is the leading submatrix of order IPARAM(5) of the c upper triangular matrix stored workl(ipntr(12)). c c\Authors c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Chao Yang Houston, Texas c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: neupd.F SID: 2.8 DATE OF SID: 07/21/02 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- subroutine zneupd(rvec , howmny, select, d , & z , ldz , sigma , workev, & bmat , n , which , nev , & tol , resid , ncv , v , & ldv , iparam, ipntr , workd , & workl, lworkl, rwork , info ) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character bmat, howmny, which*2 logical rvec integer info, ldz, ldv, lworkl, n, ncv, nev Complex*16 & sigma Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(11), ipntr(14) logical select(ncv) Double precision & rwork(ncv) Complex*16 & d(nev) , resid(n) , v(ldv,ncv), & z(ldz, nev), & workd(3*n) , workl(lworkl), workev(2*ncv) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) c c %---------------% c | Local Scalars | c %---------------% c character type*6 integer bounds, ierr , ih , ihbds, iheig , nconv , & invsub, iuptri, iwev , j , ldh , ldq , & mode , msglvl, ritz , wr , k , irz , & ibd , outncv, iq , np , numcnv, jj , & ishift Complex*16 & rnorm, temp, vl(1) Double precision & conds, sep, rtemp, eps23 logical reord c c %----------------------% c | External Subroutines | c %----------------------% c external zcopy , zgeru, zgeqr2, zlacpy, zmout, & zunm2r, ztrmm, zvout, ivout, & zlahqr c c %--------------------% c | External Functions | c %--------------------% c Double precision & dznrm2, dlamch, dlapy2 external dznrm2, dlamch, dlapy2 c Complex*16 & zdotc external zdotc c c %-----------------------% c | Executable Statements | c %-----------------------% c c %------------------------% c | Set default parameters | c %------------------------% c msglvl = mceupd mode = iparam(7) nconv = iparam(5) info = 0 c c c %---------------------------------% c | Get machine dependent constant. | c %---------------------------------% c eps23 = dlamch('Epsilon-Machine') eps23 = eps23**(2.0D+0 / 3.0D+0) c c %-------------------------------% c | Quick return | c | Check for incompatible input | c %-------------------------------% c ierr = 0 c if (nconv .le. 0) then ierr = -14 else if (n .le. 0) then ierr = -1 else if (nev .le. 0) then ierr = -2 else if (ncv .le. nev .or. ncv .gt. n) then ierr = -3 else if (which .ne. 'LM' .and. & which .ne. 'SM' .and. & which .ne. 'LR' .and. & which .ne. 'SR' .and. & which .ne. 'LI' .and. & which .ne. 'SI') then ierr = -5 else if (bmat .ne. 'I' .and. bmat .ne. 'G') then ierr = -6 else if (lworkl .lt. 3*ncv**2 + 4*ncv) then ierr = -7 else if ( (howmny .ne. 'A' .and. & howmny .ne. 'P' .and. & howmny .ne. 'S') .and. rvec ) then ierr = -13 else if (howmny .eq. 'S' ) then ierr = -12 end if c if (mode .eq. 1 .or. mode .eq. 2) then type = 'REGULR' else if (mode .eq. 3 ) then type = 'SHIFTI' else ierr = -10 end if if (mode .eq. 1 .and. bmat .eq. 'G') ierr = -11 c c %------------% c | Error Exit | c %------------% c if (ierr .ne. 0) then info = ierr go to 9000 end if c c %--------------------------------------------------------% c | Pointer into WORKL for address of H, RITZ, WORKEV, Q | c | etc... and the remaining workspace. | c | Also update pointer to be used on output. | c | Memory is laid out as follows: | c | workl(1:ncv*ncv) := generated Hessenberg matrix | c | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | c | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | c %--------------------------------------------------------% c c %-----------------------------------------------------------% c | The following is used and set by ZNEUPD. | c | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | c | Ritz values. | c | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | c | error bounds of | c | the Ritz values | c | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | c | triangular matrix | c | for H. | c | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | c | associated matrix | c | representation of | c | the invariant | c | subspace for H. | c | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | c %-----------------------------------------------------------% c ih = ipntr(5) ritz = ipntr(6) iq = ipntr(7) bounds = ipntr(8) ldh = ncv ldq = ncv iheig = bounds + ldh ihbds = iheig + ldh iuptri = ihbds + ldh invsub = iuptri + ldh*ncv ipntr(9) = iheig ipntr(11) = ihbds ipntr(12) = iuptri ipntr(13) = invsub wr = 1 iwev = wr + ncv c c %-----------------------------------------% c | irz points to the Ritz values computed | c | by _neigh before exiting _naup2. | c | ibd points to the Ritz estimates | c | computed by _neigh before exiting | c | _naup2. | c %-----------------------------------------% c irz = ipntr(14) + ncv*ncv ibd = irz + ncv c c %------------------------------------% c | RNORM is B-norm of the RESID(1:N). | c %------------------------------------% c rnorm = workl(ih+2) workl(ih+2) = zero c if (msglvl .gt. 2) then call zvout(logfil, ncv, workl(irz), ndigit, & '_neupd: Ritz values passed in from _NAUPD.') call zvout(logfil, ncv, workl(ibd), ndigit, & '_neupd: Ritz estimates passed in from _NAUPD.') end if c if (rvec) then c reord = .false. c c %---------------------------------------------------% c | Use the temporary bounds array to store indices | c | These will be used to mark the select array later | c %---------------------------------------------------% c do 10 j = 1,ncv workl(bounds+j-1) = j select(j) = .false. 10 continue c c %-------------------------------------% c | Select the wanted Ritz values. | c | Sort the Ritz values so that the | c | wanted ones appear at the tailing | c | NEV positions of workl(irr) and | c | workl(iri). Move the corresponding | c | error estimates in workl(ibd) | c | accordingly. | c %-------------------------------------% c np = ncv - nev ishift = 0 call zngets(ishift, which , nev , & np , workl(irz), workl(bounds)) c if (msglvl .gt. 2) then call zvout (logfil, ncv, workl(irz), ndigit, & '_neupd: Ritz values after calling _NGETS.') call zvout (logfil, ncv, workl(bounds), ndigit, & '_neupd: Ritz value indices after calling _NGETS.') end if c c %-----------------------------------------------------% c | Record indices of the converged wanted Ritz values | c | Mark the select array for possible reordering | c %-----------------------------------------------------% c numcnv = 0 do 11 j = 1,ncv rtemp = max(eps23, & dlapy2 ( dble(workl(irz+ncv-j)), & dimag(workl(irz+ncv-j)) )) jj = workl(bounds + ncv - j) if (numcnv .lt. nconv .and. & dlapy2( dble(workl(ibd+jj-1)), & dimag(workl(ibd+jj-1)) ) & .le. tol*rtemp) then select(jj) = .true. numcnv = numcnv + 1 if (jj .gt. nev) reord = .true. endif 11 continue c c %-----------------------------------------------------------% c | Check the count (numcnv) of converged Ritz values with | c | the number (nconv) reported by dnaupd. If these two | c | are different then there has probably been an error | c | caused by incorrect passing of the dnaupd data. | c %-----------------------------------------------------------% c if (msglvl .gt. 2) then call ivout(logfil, 1, numcnv, ndigit, & '_neupd: Number of specified eigenvalues') call ivout(logfil, 1, nconv, ndigit, & '_neupd: Number of "converged" eigenvalues') end if c if (numcnv .ne. nconv) then info = -15 go to 9000 end if c c %-------------------------------------------------------% c | Call LAPACK routine zlahqr to compute the Schur form | c | of the upper Hessenberg matrix returned by ZNAUPD. | c | Make a copy of the upper Hessenberg matrix. | c | Initialize the Schur vector matrix Q to the identity. | c %-------------------------------------------------------% c call zcopy(ldh*ncv, workl(ih), 1, workl(iuptri), 1) call zlaset('All', ncv, ncv , & zero , one, workl(invsub), & ldq) call zlahqr(.true., .true. , ncv , & 1 , ncv , workl(iuptri), & ldh , workl(iheig) , 1 , & ncv , workl(invsub), ldq , & ierr) call zcopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c if (ierr .ne. 0) then info = -8 go to 9000 end if c if (msglvl .gt. 1) then call zvout (logfil, ncv, workl(iheig), ndigit, & '_neupd: Eigenvalues of H') call zvout (logfil, ncv, workl(ihbds), ndigit, & '_neupd: Last row of the Schur vector matrix') if (msglvl .gt. 3) then call zmout (logfil , ncv, ncv , & workl(iuptri), ldh, ndigit, & '_neupd: The upper triangular matrix ') end if end if c if (reord) then c c %-----------------------------------------------% c | Reorder the computed upper triangular matrix. | c %-----------------------------------------------% c call ztrsen('None' , 'V' , select , & ncv , workl(iuptri), ldh , & workl(invsub), ldq , workl(iheig), & nconv , conds , sep , & workev , ncv , ierr) c if (ierr .eq. 1) then info = 1 go to 9000 end if c if (msglvl .gt. 2) then call zvout (logfil, ncv, workl(iheig), ndigit, & '_neupd: Eigenvalues of H--reordered') if (msglvl .gt. 3) then call zmout(logfil , ncv, ncv , & workl(iuptri), ldq, ndigit, & '_neupd: Triangular matrix after re-ordering') end if end if c end if c c %---------------------------------------------% c | Copy the last row of the Schur basis matrix | c | to workl(ihbds). This vector will be used | c | to compute the Ritz estimates of converged | c | Ritz values. | c %---------------------------------------------% c call zcopy(ncv , workl(invsub+ncv-1), ldq, & workl(ihbds), 1) c c %--------------------------------------------% c | Place the computed eigenvalues of H into D | c | if a spectral transformation was not used. | c %--------------------------------------------% c if (type .eq. 'REGULR') then call zcopy(nconv, workl(iheig), 1, d, 1) end if c c %----------------------------------------------------------% c | Compute the QR factorization of the matrix representing | c | the wanted invariant subspace located in the first NCONV | c | columns of workl(invsub,ldq). | c %----------------------------------------------------------% c call zgeqr2(ncv , nconv , workl(invsub), & ldq , workev, workev(ncv+1), & ierr) c c %--------------------------------------------------------% c | * Postmultiply V by Q using zunm2r. | c | * Copy the first NCONV columns of VQ into Z. | c | * Postmultiply Z by R. | c | The N by NCONV matrix Z is now a matrix representation | c | of the approximate invariant subspace associated with | c | the Ritz values in workl(iheig). The first NCONV | c | columns of V are now approximate Schur vectors | c | associated with the upper triangular matrix of order | c | NCONV in workl(iuptri). | c %--------------------------------------------------------% c call zunm2r('Right', 'Notranspose', n , & ncv , nconv , workl(invsub), & ldq , workev , v , & ldv , workd(n+1) , ierr) call zlacpy('All', n, nconv, v, ldv, z, ldz) c do 20 j=1, nconv c c %---------------------------------------------------% c | Perform both a column and row scaling if the | c | diagonal element of workl(invsub,ldq) is negative | c | I'm lazy and don't take advantage of the upper | c | triangular form of workl(iuptri,ldq). | c | Note that since Q is orthogonal, R is a diagonal | c | matrix consisting of plus or minus ones. | c %---------------------------------------------------% c if ( dble( workl(invsub+(j-1)*ldq+j-1) ) .lt. & dble(zero) ) then call zscal(nconv, -one, workl(iuptri+j-1), ldq) call zscal(nconv, -one, workl(iuptri+(j-1)*ldq), 1) end if c 20 continue c if (howmny .eq. 'A') then c c %--------------------------------------------% c | Compute the NCONV wanted eigenvectors of T | c | located in workl(iuptri,ldq). | c %--------------------------------------------% c do 30 j=1, ncv if (j .le. nconv) then select(j) = .true. else select(j) = .false. end if 30 continue c call ztrevc('Right', 'Select' , select , & ncv , workl(iuptri), ldq , & vl , 1 , workl(invsub), & ldq , ncv , outncv , & workev , rwork , ierr) c if (ierr .ne. 0) then info = -9 go to 9000 end if c c %------------------------------------------------% c | Scale the returning eigenvectors so that their | c | Euclidean norms are all one. LAPACK subroutine | c | ztrevc returns each eigenvector normalized so | c | that the element of largest magnitude has | c | magnitude 1. | c %------------------------------------------------% c do 40 j=1, nconv rtemp = dznrm2(ncv, workl(invsub+(j-1)*ldq), 1) rtemp = dble(one) / rtemp call zdscal ( ncv, rtemp, & workl(invsub+(j-1)*ldq), 1 ) c c %------------------------------------------% c | Ritz estimates can be obtained by taking | c | the inner product of the last row of the | c | Schur basis of H with eigenvectors of T. | c | Note that the eigenvector matrix of T is | c | upper triangular, thus the length of the | c | inner product can be set to j. | c %------------------------------------------% c workev(j) = zdotc(j, workl(ihbds), 1, & workl(invsub+(j-1)*ldq), 1) 40 continue c if (msglvl .gt. 2) then call zcopy(nconv, workl(invsub+ncv-1), ldq, & workl(ihbds), 1) call zvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Last row of the eigenvector matrix for T') if (msglvl .gt. 3) then call zmout(logfil , ncv, ncv , & workl(invsub), ldq, ndigit, & '_neupd: The eigenvector matrix for T') end if end if c c %---------------------------------------% c | Copy Ritz estimates into workl(ihbds) | c %---------------------------------------% c call zcopy(nconv, workev, 1, workl(ihbds), 1) c c %----------------------------------------------% c | The eigenvector matrix Q of T is triangular. | c | Form Z*Q. | c %----------------------------------------------% c call ztrmm('Right' , 'Upper' , 'No transpose', & 'Non-unit', n , nconv , & one , workl(invsub), ldq , & z , ldz) end if c else c c %--------------------------------------------------% c | An approximate invariant subspace is not needed. | c | Place the Ritz values computed ZNAUPD into D. | c %--------------------------------------------------% c call zcopy(nconv, workl(ritz), 1, d, 1) call zcopy(nconv, workl(ritz), 1, workl(iheig), 1) call zcopy(nconv, workl(bounds), 1, workl(ihbds), 1) c end if c c %------------------------------------------------% c | Transform the Ritz values and possibly vectors | c | and corresponding error bounds of OP to those | c | of A*x = lambda*B*x. | c %------------------------------------------------% c if (type .eq. 'REGULR') then c if (rvec) & call zscal(ncv, rnorm, workl(ihbds), 1) c else c c %---------------------------------------% c | A spectral transformation was used. | c | * Determine the Ritz estimates of the | c | Ritz values in the original system. | c %---------------------------------------% c if (rvec) & call zscal(ncv, rnorm, workl(ihbds), 1) c do 50 k=1, ncv temp = workl(iheig+k-1) workl(ihbds+k-1) = workl(ihbds+k-1) / temp / temp 50 continue c end if c c %-----------------------------------------------------------% c | * Transform the Ritz values back to the original system. | c | For TYPE = 'SHIFTI' the transformation is | c | lambda = 1/theta + sigma | c | NOTES: | c | *The Ritz vectors are not affected by the transformation. | c %-----------------------------------------------------------% c if (type .eq. 'SHIFTI') then do 60 k=1, nconv d(k) = one / workl(iheig+k-1) + sigma 60 continue end if c if (type .ne. 'REGULR' .and. msglvl .gt. 1) then call zvout (logfil, nconv, d, ndigit, & '_neupd: Untransformed Ritz values.') call zvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Ritz estimates of the untransformed Ritz values.') else if ( msglvl .gt. 1) then call zvout (logfil, nconv, d, ndigit, & '_neupd: Converged Ritz values.') call zvout (logfil, nconv, workl(ihbds), ndigit, & '_neupd: Associated Ritz estimates.') end if c c %-------------------------------------------------% c | Eigenvector Purification step. Formally perform | c | one of inverse subspace iteration. Only used | c | for MODE = 3. See reference 3. | c %-------------------------------------------------% c if (rvec .and. howmny .eq. 'A' .and. type .eq. 'SHIFTI') then c c %------------------------------------------------% c | Purify the computed Ritz vectors by adding a | c | little bit of the residual vector: | c | T | c | resid(:)*( e s ) / theta | c | NCV | c | where H s = s theta. | c %------------------------------------------------% c do 100 j=1, nconv if (workl(iheig+j-1) .ne. zero) then workev(j) = workl(invsub+(j-1)*ldq+ncv-1) / & workl(iheig+j-1) endif 100 continue c %---------------------------------------% c | Perform a rank one update to Z and | c | purify all the Ritz vectors together. | c %---------------------------------------% c call zgeru (n, nconv, one, resid, 1, workev, 1, z, ldz) c end if c 9000 continue c return c c %---------------% c | End of zneupd| c %---------------% c end arpack-akloeckner-07/SRC/zngets.f0000644000175000017500000001271210670622032016604 0ustar andreasandreasc\BeginDoc c c\Name: zngets c c\Description: c Given the eigenvalues of the upper Hessenberg matrix H, c computes the NP shifts AMU that are zeros of the polynomial of c degree NP which filters out components of the unwanted eigenvectors c corresponding to the AMU's based on some given criteria. c c NOTE: call this even in the case of user specified shifts in order c to sort the eigenvalues, and error bounds of H for later use. c c\Usage: c call zngets c ( ISHIFT, WHICH, KEV, NP, RITZ, BOUNDS ) c c\Arguments c ISHIFT Integer. (INPUT) c Method for selecting the implicit shifts at each iteration. c ISHIFT = 0: user specified shifts c ISHIFT = 1: exact shift with respect to the matrix H. c c WHICH Character*2. (INPUT) c Shift selection criteria. c 'LM' -> want the KEV eigenvalues of largest magnitude. c 'SM' -> want the KEV eigenvalues of smallest magnitude. c 'LR' -> want the KEV eigenvalues of largest REAL part. c 'SR' -> want the KEV eigenvalues of smallest REAL part. c 'LI' -> want the KEV eigenvalues of largest imaginary part. c 'SI' -> want the KEV eigenvalues of smallest imaginary part. c c KEV Integer. (INPUT) c The number of desired eigenvalues. c c NP Integer. (INPUT) c The number of shifts to compute. c c RITZ Complex*16 array of length KEV+NP. (INPUT/OUTPUT) c On INPUT, RITZ contains the the eigenvalues of H. c On OUTPUT, RITZ are sorted so that the unwanted c eigenvalues are in the first NP locations and the wanted c portion is in the last KEV locations. When exact shifts are c selected, the unwanted part corresponds to the shifts to c be applied. Also, if ISHIFT .eq. 1, the unwanted eigenvalues c are further sorted so that the ones with largest Ritz values c are first. c c BOUNDS Complex*16 array of length KEV+NP. (INPUT/OUTPUT) c Error bounds corresponding to the ordering in RITZ. c c c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Local variables: c xxxxxx Complex*16 c c\Routines called: c zsortc ARPACK sorting routine. c ivout ARPACK utility routine that prints integers. c arscnd ARPACK utility routine for timing. c zvout ARPACK utility routine that prints vectors. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ngets.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\Remarks c 1. This routine does not keep complex conjugate pairs of c eigenvalues together. c c\EndLib c c----------------------------------------------------------------------- c subroutine zngets ( ishift, which, kev, np, ritz, bounds) c c %----------------------------------------------------% c | Include files for debugging and timing information | c %----------------------------------------------------% c include 'debug.h' include 'stat.h' c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which integer ishift, kev, np c c %-----------------% c | Array Arguments | c %-----------------% c Complex*16 & bounds(kev+np), ritz(kev+np) c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero parameter (one = (1.0D+0, 0.0D+0), zero = (0.0D+0, 0.0D+0)) c c %---------------% c | Local Scalars | c %---------------% c integer msglvl c c %----------------------% c | External Subroutines | c %----------------------% c external zvout, zsortc, arscnd c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------% c | Initialize timing statistics | c | & message level for debugging | c %-------------------------------% c call arscnd (t0) msglvl = mcgets c call zsortc (which, .true., kev+np, ritz, bounds) c if ( ishift .eq. 1 ) then c c %-------------------------------------------------------% c | Sort the unwanted Ritz values used as shifts so that | c | the ones with largest Ritz estimates are first | c | This will tend to minimize the effects of the | c | forward instability of the iteration when the shifts | c | are applied in subroutine znapps. | c | Be careful and use 'SM' since we want to sort BOUNDS! | c %-------------------------------------------------------% c call zsortc ( 'SM', .true., np, bounds, ritz ) c end if c call arscnd (t1) tcgets = tcgets + (t1 - t0) c if (msglvl .gt. 0) then call ivout (logfil, 1, kev, ndigit, '_ngets: KEV is') call ivout (logfil, 1, np, ndigit, '_ngets: NP is') call zvout (logfil, kev+np, ritz, ndigit, & '_ngets: Eigenvalues of current H matrix ') call zvout (logfil, kev+np, bounds, ndigit, & '_ngets: Ritz estimates of the current KEV+NP Ritz values') end if c return c c %---------------% c | End of zngets | c %---------------% c end arpack-akloeckner-07/SRC/zsortc.f0000644000175000017500000001766006136215723016634 0ustar andreasandreasc\BeginDoc c c\Name: zsortc c c\Description: c Sorts the Complex*16 array in X into the order c specified by WHICH and optionally applies the permutation to the c Double precision array Y. c c\Usage: c call zsortc c ( WHICH, APPLY, N, X, Y ) c c\Arguments c WHICH Character*2. (Input) c 'LM' -> sort X into increasing order of magnitude. c 'SM' -> sort X into decreasing order of magnitude. c 'LR' -> sort X with real(X) in increasing algebraic order c 'SR' -> sort X with real(X) in decreasing algebraic order c 'LI' -> sort X with imag(X) in increasing algebraic order c 'SI' -> sort X with imag(X) in decreasing algebraic order c c APPLY Logical. (Input) c APPLY = .TRUE. -> apply the sorted order to array Y. c APPLY = .FALSE. -> do not apply the sorted order to array Y. c c N Integer. (INPUT) c Size of the arrays. c c X Complex*16 array of length N. (INPUT/OUTPUT) c This is the array to be sorted. c c Y Complex*16 array of length N. (INPUT/OUTPUT) c c\EndDoc c c----------------------------------------------------------------------- c c\BeginLib c c\Routines called: c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c c\Author c Danny Sorensen Phuong Vu c Richard Lehoucq CRPC / Rice University c Dept. of Computational & Houston, Texas c Applied Mathematics c Rice University c Houston, Texas c c Adapted from the sort routine in LANSO. c c\SCCS Information: @(#) c FILE: sortc.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine zsortc (which, apply, n, x, y) c c %------------------% c | Scalar Arguments | c %------------------% c character*2 which logical apply integer n c c %-----------------% c | Array Arguments | c %-----------------% c Complex*16 & x(0:n-1), y(0:n-1) c c %---------------% c | Local Scalars | c %---------------% c integer i, igap, j Complex*16 & temp Double precision & temp1, temp2 c c %--------------------% c | External functions | c %--------------------% c Double precision & dlapy2 c c %--------------------% c | Intrinsic Functions | c %--------------------% Intrinsic & dble, dimag c c %-----------------------% c | Executable Statements | c %-----------------------% c igap = n / 2 c if (which .eq. 'LM') then c c %--------------------------------------------% c | Sort X into increasing order of magnitude. | c %--------------------------------------------% c 10 continue if (igap .eq. 0) go to 9000 c do 30 i = igap, n-1 j = i-igap 20 continue c if (j.lt.0) go to 30 c temp1 = dlapy2(dble(x(j)),dimag(x(j))) temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap))) c if (temp1.gt.temp2) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 30 end if j = j-igap go to 20 30 continue igap = igap / 2 go to 10 c else if (which .eq. 'SM') then c c %--------------------------------------------% c | Sort X into decreasing order of magnitude. | c %--------------------------------------------% c 40 continue if (igap .eq. 0) go to 9000 c do 60 i = igap, n-1 j = i-igap 50 continue c if (j .lt. 0) go to 60 c temp1 = dlapy2(dble(x(j)),dimag(x(j))) temp2 = dlapy2(dble(x(j+igap)),dimag(x(j+igap))) c if (temp1.lt.temp2) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 60 endif j = j-igap go to 50 60 continue igap = igap / 2 go to 40 c else if (which .eq. 'LR') then c c %------------------------------------------------% c | Sort XREAL into increasing order of algebraic. | c %------------------------------------------------% c 70 continue if (igap .eq. 0) go to 9000 c do 90 i = igap, n-1 j = i-igap 80 continue c if (j.lt.0) go to 90 c if (dble(x(j)).gt.dble(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 90 endif j = j-igap go to 80 90 continue igap = igap / 2 go to 70 c else if (which .eq. 'SR') then c c %------------------------------------------------% c | Sort XREAL into decreasing order of algebraic. | c %------------------------------------------------% c 100 continue if (igap .eq. 0) go to 9000 do 120 i = igap, n-1 j = i-igap 110 continue c if (j.lt.0) go to 120 c if (dble(x(j)).lt.dble(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 120 endif j = j-igap go to 110 120 continue igap = igap / 2 go to 100 c else if (which .eq. 'LI') then c c %--------------------------------------------% c | Sort XIMAG into increasing algebraic order | c %--------------------------------------------% c 130 continue if (igap .eq. 0) go to 9000 do 150 i = igap, n-1 j = i-igap 140 continue c if (j.lt.0) go to 150 c if (dimag(x(j)).gt.dimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 150 endif j = j-igap go to 140 150 continue igap = igap / 2 go to 130 c else if (which .eq. 'SI') then c c %---------------------------------------------% c | Sort XIMAG into decreasing algebraic order | c %---------------------------------------------% c 160 continue if (igap .eq. 0) go to 9000 do 180 i = igap, n-1 j = i-igap 170 continue c if (j.lt.0) go to 180 c if (dimag(x(j)).lt.dimag(x(j+igap))) then temp = x(j) x(j) = x(j+igap) x(j+igap) = temp c if (apply) then temp = y(j) y(j) = y(j+igap) y(j+igap) = temp end if else go to 180 endif j = j-igap go to 170 180 continue igap = igap / 2 go to 160 end if c 9000 continue return c c %---------------% c | End of zsortc | c %---------------% c end arpack-akloeckner-07/SRC/zstatn.f0000644000175000017500000000230506136215723016621 0ustar andreasandreasc c\SCCS Information: @(#) c FILE: statn.F SID: 2.2 DATE OF SID: 4/20/96 RELEASE: 2 c c %---------------------------------------------% c | Initialize statistic and timing information | c | for complex nonsymmetric Arnoldi code. | c %---------------------------------------------% subroutine zstatn c c %--------------------------------% c | See stat.doc for documentation | c %--------------------------------% c include 'stat.h' c %-----------------------% c | Executable Statements | c %-----------------------% nopx = 0 nbx = 0 nrorth = 0 nitref = 0 nrstrt = 0 tcaupd = 0.0D+0 tcaup2 = 0.0D+0 tcaitr = 0.0D+0 tceigh = 0.0D+0 tcgets = 0.0D+0 tcapps = 0.0D+0 tcconv = 0.0D+0 titref = 0.0D+0 tgetv0 = 0.0D+0 trvec = 0.0D+0 c %----------------------------------------------------% c | User time including reverse communication overhead | c %----------------------------------------------------% tmvopx = 0.0D+0 tmvbx = 0.0D+0 return c c %---------------% c | End of zstatn | c %---------------% c end arpack-akloeckner-07/SRC/version.h0000644000175000017500000000234606053007300016756 0ustar andreasandreas/* In the current version, the parameter KAPPA in the Kahan's test for orthogonality is set to 0.717, the same as used by Gragg & Reichel. However computational experience indicates that this is a little too strict and will frequently force reorthogonalization when it is not necessary to do so. Also the "moving boundary" idea is not currently activated in the nonsymmetric code since it is not conclusive that it's the right thing to do all the time. Requires further investigation. As of 02/01/93 Richard Lehoucq assumes software control of the codes from Phuong Vu. On 03/01/93 all the *.F files were migrated SCCS. The 1.1 version of codes are those received from Phuong Vu. The frozen version of 07/08/92 is now considered version 1.1. Version 2.1 contains two new symmetric routines, sesrt and seupd. Changes as well as bug fixes for version 1.1 codes that were only corrected for programming bugs are version 1.2. These 1.2 versions will also be in version 2.1. Subroutine [d,s]saupd now requires slightly more workspace. See [d,s]saupd for the details. \SCCS Information: @(#) FILE: version.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */ #define VERSION_NUMBER ' 2.1' #define VERSION_DATE ' 11/15/95' arpack-akloeckner-07/SRC/Makefile0000644000175000017500000000425510670623441016573 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: Makefile # # Purpose: Sources Makefile # # Creation date: February 22, 1996 # # Modified: September 9, 1996 # # Send bug reports, comments or suggestions to arpack.caam.rice.edu # ############################################################################ #\SCCS Information: @(#) # FILE: Makefile SID: 2.1 DATE OF SID: 9/9/96 RELEASE: 2 include ../ARmake.inc ############################################################################ # To create or add to the library, enter make followed by one or # more of the precisions desired. Some examples: # make single # make single complex # make single double complex complex16 # Alternatively, the command # make # without any arguments creates a library of all four precisions. # The name of the library is defined by $(ARPACKLIB) in # ../ARmake.inc and is created at the next higher directory level. SOBJ = sgetv0.o slaqrb.o sstqrb.o ssortc.o ssortr.o sstatn.o sstats.o \ snaitr.o snapps.o snaup2.o snaupd.o snconv.o sneigh.o sngets.o \ ssaitr.o ssapps.o ssaup2.o ssaupd.o ssconv.o sseigt.o ssgets.o \ sneupd.o sseupd.o ssesrt.o DOBJ = dgetv0.o dlaqrb.o dstqrb.o dsortc.o dsortr.o dstatn.o dstats.o \ dnaitr.o dnapps.o dnaup2.o dnaupd.o dnconv.o dneigh.o dngets.o \ dsaitr.o dsapps.o dsaup2.o dsaupd.o dsconv.o dseigt.o dsgets.o \ dneupd.o dseupd.o dsesrt.o COBJ = cnaitr.o cnapps.o cnaup2.o cnaupd.o cneigh.o cneupd.o cngets.o \ cgetv0.o csortc.o cstatn.o ZOBJ = znaitr.o znapps.o znaup2.o znaupd.o zneigh.o zneupd.o zngets.o \ zgetv0.o zsortc.o zstatn.o .f.o: $(FC) $(FFLAGS) -c $< all: single double complex complex16 single: $(SOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ) $(RANLIB) $(ARPACKLIB) double: $(DOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ) $(RANLIB) $(ARPACKLIB) complex: $(COBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(COBJ) $(RANLIB) $(ARPACKLIB) complex16: $(ZOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(ZOBJ) $(RANLIB) $(ARPACKLIB) # sdrv: ddrv: cdrv: zdrv: # # clean - remove all object files # clean: rm -f *.o a.out core arpack-akloeckner-07/SRC/dnaupe.f0000644000175000017500000000000006112017221016523 0ustar andreasandreasarpack-akloeckner-07/SRC/snaupe.f0000644000175000017500000000000006112017241016544 0ustar andreasandreasarpack-akloeckner-07/SRC/Makefile~0000644000175000017500000000430210670623371016764 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: Makefile # # Purpose: Sources Makefile # # Creation date: February 22, 1996 # # Modified: September 9, 1996 # # Send bug reports, comments or suggestions to arpack.caam.rice.edu # ############################################################################ #\SCCS Information: @(#) # FILE: Makefile SID: 2.1 DATE OF SID: 9/9/96 RELEASE: 2 include ../ARmake.inc ############################################################################ # To create or add to the library, enter make followed by one or # more of the precisions desired. Some examples: # make single # make single complex # make single double complex complex16 # Alternatively, the command # make # without any arguments creates a library of all four precisions. # The name of the library is defined by $(ARPACKLIB) in # ../ARmake.inc and is created at the next higher directory level. SOBJ = sgetv0.o slaqrb.o sstqrb.o ssortc.o ssortr.o sstatn.o sstats.o \ snaitr.o snapps.o snaup2.o snaupd.o snconv.o sneigh.o sngets.o \ ssaitr.o ssapps.o ssaup2.o ssaupd.o ssconv.o sseigt.o ssgets.o \ sneupd.o sseupd.o ssesrt.o DOBJ = dgetv0.o dlaqrb.o dstqrb.o dsortc.o dsortr.o dstatn.o dstats.o \ dnaitr.o dnapps.o dnaup2.o dnaupd.o dnconv.o dneigh.o dngets.o \ dsaitr.o dsapps.o dsaup2.o dsaupd.o dsconv.o dseigt.o dsgets.o \ dneupd.o dseupd.o dsesrt.o COBJ = cnaitr.o cnapps.o cnaup2.o cnaupd.o cneigh.o cneupd.o cngets.o \ cgetv0.o csortc.o cstatn.o ZOBJ = znaitr.o znapps.o znaup2.o znaupd.o zneigh.o zneupd.o zngets.o \ zgetv0.o zsortc.o zstatn.o .f.o: $(FC) $(FFLAGS) -c $< all: single double complex complex16 single: $(SOBJ) echo "HOME $(home)" $(AR) $(ARFLAGS) $(ARPACKLIB) $(SOBJ) $(RANLIB) $(ARPACKLIB) double: $(DOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(DOBJ) $(RANLIB) $(ARPACKLIB) complex: $(COBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(COBJ) $(RANLIB) $(ARPACKLIB) complex16: $(ZOBJ) $(AR) $(ARFLAGS) $(ARPACKLIB) $(ZOBJ) $(RANLIB) $(ARPACKLIB) # sdrv: ddrv: cdrv: zdrv: # # clean - remove all object files # clean: rm -f *.o a.out core arpack-akloeckner-07/SRC/libarpack_LINUX.a0000644000175000017500000140122610670623404020203 0ustar andreasandreas! / 1189291780 0 0 0 3878 ` òjjjj!!55NâNâY†Y†aaaeÞeÞeÞj®j®j®j®Ž>Ž>Ž>Ž>¯Š¯Š¯Š¯ŠÛÒÛÒÛÒÛÒ÷~÷~÷~÷~þþþþ ž ž ž ž::::?2?2?2?2U&U&U&U&{v{v{v{v–~–~–~–~œ¶œ¶œ¶œ¶¥J¥J¥J¥J¯†¯†¯†¯†ãnãnãnãn ^ ^šššš%–%–:Ê:ÊVFVF`¾`¾hhhlêlêlêqºqºqºqº–2–2–2–2¹>¹>¹>¹>ææææúúúúÚÚÚÚîîîî&¾&¾&¾&¾KKKKaöaöaöaöˆ²ˆ²ˆ²ˆ²£Þ£Þ£Þ£Þªvªvªvªv³ ³ ³ ³ ½F½F½F½FñÞñÞñÞñÞÞÞ"þ"þ"þ"þJúJúJúJújÊjÊjÊjÊ’þ’þ’þ’þ®®®®º²º²º²º²ã¦ã¦ã¦ã¦ììììþjþj   ÒÒÒÒ8Z8Z8Z8ZZvZvZvZv„^„^„^„^ŸºŸºŸºŸº¬‚¬‚¬‚¬‚× × × × ßzßzßzßzñîñîýÆýÆýÆsgetv0___i686.get_pc_thunk.bxdebug_timing_slaqrb___i686.get_pc_thunk.bxsstqrb___i686.get_pc_thunk.bxssortc___i686.get_pc_thunk.bxssortr___i686.get_pc_thunk.bxtiming_sstatn___i686.get_pc_thunk.cxtiming_sstats___i686.get_pc_thunk.cxsnaitr___i686.get_pc_thunk.bxtiming_debug_snapps___i686.get_pc_thunk.bxdebug_timing_snaup2___i686.get_pc_thunk.bxdebug_timing_snaupd___i686.get_pc_thunk.bxdebug_timing_debug_timing_snconv___i686.get_pc_thunk.bxsneigh___i686.get_pc_thunk.bxdebug_timing_sngets___i686.get_pc_thunk.bxdebug_timing_ssaitr___i686.get_pc_thunk.bxtiming_debug_ssapps___i686.get_pc_thunk.bxdebug_timing_ssaup2___i686.get_pc_thunk.bxdebug_timing_ssaupd___i686.get_pc_thunk.bxdebug_timing_debug_timing_ssconv___i686.get_pc_thunk.bxsseigt___i686.get_pc_thunk.bxdebug_timing_ssgets___i686.get_pc_thunk.bxdebug_timing_sneupd___i686.get_pc_thunk.bxdebug_timing_sseupd___i686.get_pc_thunk.bxdebug_timing_ssesrt___i686.get_pc_thunk.bxdgetv0___i686.get_pc_thunk.bxdebug_timing_dlaqrb___i686.get_pc_thunk.bxdstqrb___i686.get_pc_thunk.bxdsortc___i686.get_pc_thunk.bxdsortr___i686.get_pc_thunk.bxtiming_dstatn___i686.get_pc_thunk.cxtiming_dstats___i686.get_pc_thunk.cxdnaitr___i686.get_pc_thunk.bxtiming_debug_dnapps___i686.get_pc_thunk.bxdebug_timing_dnaup2___i686.get_pc_thunk.bxdebug_timing_dnaupd___i686.get_pc_thunk.bxdebug_timing_debug_timing_dnconv___i686.get_pc_thunk.bxdneigh___i686.get_pc_thunk.bxdebug_timing_dngets___i686.get_pc_thunk.bxdebug_timing_dsaitr___i686.get_pc_thunk.bxtiming_debug_dsapps___i686.get_pc_thunk.bxdebug_timing_dsaup2___i686.get_pc_thunk.bxdebug_timing_dsaupd___i686.get_pc_thunk.bxdebug_timing_debug_timing_dsconv___i686.get_pc_thunk.bxdseigt___i686.get_pc_thunk.bxdebug_timing_dsgets___i686.get_pc_thunk.bxdebug_timing_dneupd___i686.get_pc_thunk.bxdebug_timing_dseupd___i686.get_pc_thunk.bxdebug_timing_dsesrt___i686.get_pc_thunk.bxcnaitr___i686.get_pc_thunk.bxtiming_debug_cnapps___i686.get_pc_thunk.bxdebug_timing_cnaup2___i686.get_pc_thunk.bxdebug_timing_cnaupd___i686.get_pc_thunk.bxdebug_timing_cneigh___i686.get_pc_thunk.bxdebug_timing_cneupd___i686.get_pc_thunk.bxdebug_timing_debug_timing_cngets___i686.get_pc_thunk.bxcgetv0___i686.get_pc_thunk.bxtiming_debug_csortc___i686.get_pc_thunk.bxtiming_cstatn___i686.get_pc_thunk.cxznaitr___i686.get_pc_thunk.bxtiming_debug_znapps___i686.get_pc_thunk.bxdebug_timing_znaup2___i686.get_pc_thunk.bxdebug_timing_znaupd___i686.get_pc_thunk.bxdebug_timing_zneigh___i686.get_pc_thunk.bxdebug_timing_zneupd___i686.get_pc_thunk.bxdebug_timing_debug_timing_zngets___i686.get_pc_thunk.bxzgetv0___i686.get_pc_thunk.bxtiming_debug_zsortc___i686.get_pc_thunk.bxtiming_zstatn___i686.get_pc_thunk.cxsgetv0.o/ 1189291774 1000 1000 100644 4464 ` ELFä4( U‰åWVSƒì|‹M ‹E èüÿÿÿËU‹}‰MЋM4‰EÜ‹E(‰Uà‹u‰}Ø‹U$‰M¸‹},‰EÈ‹ƒ‰uÔ‹u0…À‰UÌ‹U8‰}ĉuÀ‰U¼t4º¸¿‰“ ¾1ɉƒ$‰»(‰³,‰‹‹Mà‹1…ö„á‹uܶ‹‹…É„Ë P ^ d j$p „ Ž ”"ª ³ ¹ Á Ï × ë$ñ #!? I"g#r ‚  —"« »#Æ è#ó %* 5 = C I$R f n t z$ƒ š »%Ø ë& '- @&K$w!»!Ì Ô Ú à$æ ÷$ý slaqrb.o/ 1189291774 1000 1000 100644 5068 ` ELF@4( U‰åWVS쌋U‹M èüÿÿÿËE‹}‰U°‹U ‰M¬‹M$‰E¤‹E‰½Xÿÿÿ‹u‰•8ÿÿÿ‹U¬‰4ÿÿÿ‹},‰E ‹‰u¨‹u(‰E”‰}˜‰uœ‹2Ç…ö„¢‹E¨‹M¤‹8‹9Ç„›‰ñƒéx‹UœÇƒÂIyô‹MœÙè)ø@º }ÌÙT±ü³‰…tÿÿÿ‰T$‰4$ÙÈþÿÿèüÿÿÿÙ]ÔEÈÙEÔÙ…ÈþÿÿØñÙÉÙ]ÈÙ]̉|$‰$èüÿÿÿ¹ “ ‰L$‰$èüÿÿÿÙ`ÿÿÿ‹u°Û…tÿÿÿص`ÿÿÿ‹>…ÿØMÈÙhÿÿÿ„)ÇE‹E¬¾‹‰UŒƒêx¹‹½Xÿÿÿ1FLJ‹}”ùJyç‹M¤‹}¨‹‹7‰•ìþÿÿ‹½tÿÿÿ‹•tÿÿÿ‹ìþÿÿÁç)×ÿ‰}ˆ‰èþÿÿ‰µ|ÿÿÿ‹èþÿÿ9ÎgÇE„‹uˆ…ö‰µ\ÿÿÿˆDEÄ‹U”»‰… ÿÿÿ‰Èqÿ‰½ÿÿÿ‹}”ƒè‰µ0ÿÿÿ¯Â‰ò¯×uØȉ…Hÿÿÿƒʉ•Dÿÿÿ}¼UÀ‰…ÿÿÿMÜEЉµÿÿÿ‰•üþÿÿ‰½øþÿÿ‰ôþÿÿ‰…ðþÿÿ‹µ|ÿÿÿ‹èþÿÿ)ñ‹µèþÿÿ‰ÏO‰u€ˆë‹…|ÿÿÿ‹U”‹XÿÿÿH¯Â‹|ÿÿÿTˆü‰ð‰•Tÿÿÿ)È@‰…Pÿÿÿ‹•ÿÿÿ‰•LÿÿÿëÝÙÙÉÚéßàžƒ‹µ,ÿÿÿO‰u€ˆ‹u€‹E”‹U€ƒî‹M€¯ÆIЋ•XÿÿÿÙD‚ø‰È‰,ÿÿÿ‹M”Ùá¯Á‹M€ÈÙD‚üÙáÞÁÙîÙÉÝáßàÝÙž„´Ù…`ÿÿÿ‹E”‹U€ÞɯðÙ…hÿÿÿÙÉ ‹µXÿÿÿÝáßàžÙDŽüÙá‚aÿÿÿÝÚÚéßàž‚cÿÿÿ‹}¨‹M€‹7‰|ÿÿÿ9Î}‹U”‰Èƒè¯ÂÈ‹XÿÿÿÇDü‹M€90ÿÿÿŽn‹u°‹>…ÿu ‰M‹èþÿÿ‰MŒƒ}„ ”Àƒ}„” Ш„Ô‹•èþÿÿ‹M”‹…èþÿÿƒê‹½Xÿÿÿ¯Ê‹µHÿÿÿÁÙDüÙD·øÙÉÙáÙÉÙáÞÁÙÀÙÁÙÉØ‹ÙÉØ‹ÙÉÞÊÙ•pÿÿÿÙlÿÿÿ‰•xÿÿÿ+U€‰•äþÿÿˆ[‹½xÿÿÿ‹M”‹u”ƒï‹U”¯ù‹xÿÿÿ¯Î‹µxÿÿÿ‰ÈN)Љ…ÿÿÿ‹E”‰µÿÿÿ÷؉…¸þÿÿ¶¼'Ù…pÿÿÿ‹µxÿÿÿ‹•ÿÿÿÙ…lÿÿÿ‹…Xÿÿÿò‹µxÿÿÿÙDü1ÜêÜ鋵XÿÿÿÙÂÙ†ÙÉØËÙÁÙD†ÙÉØäÙÊØçØ4–ÙÊÞæÙÉØD†üÙÍ‹E€Þä9…xÿÿÿÙÄÙÄÙáÙÉÙáÞÁÙÁÙáÞÁÜýÜüÞùÙÌÙUØÙËÙUÜÙÌÙUà„âÙÊ‹•xÿÿÿÙáÙÉÙáÙËÙáÙÌÙáÙD†øÙËÙáÙD†üÙÌÙáÙÊÞÁÙËÙáÙÉÞÂÞÊÞÂÙÊÞÉØ`ÿÿÿÚéßàžs/‹…ÿÿÿ‹µ¸þÿÿµÿÿÿ‰…xÿÿÿñH‰…ÿÿÿ÷ÿäþÿÿ‰òþÿÿÝØ‹èþÿÿ‹•xÿÿÿ‹½xÿÿÿ)ÑI‰½àþÿÿ‰@ÿÿÿˆU‹µèþÿÿ‹E)Ɖµ<ÿÿÿé‡v‹•|ÿÿÿ9•xÿÿÿŽ&‹…àþÿÿ‹}”‹àþÿÿƒè‹µXÿÿÿ¯ÇÈ€t†ÿ€‹EÀÙE¼ÙE܃øÙÁØÉ„¶‹àþÿÿAƒø‰(ÿÿÿ„CÝØÝØÝØÿ@ÿÿÿ‹½(ÿÿÿ‰½àþÿÿˆ¸‹èþÿÿ‹½àþÿÿ)ùAƒù‰MÀ~ÇEÀ‹•xÿÿÿ9•àþÿÿ¤‹•øþÿÿ‰T$‹½ÿÿÿ‰|$ ‹ôþÿÿ‰L$‹…ÿÿÿ‰D$‹µüþÿÿ‰4$èüÿÿÿ‹•xÿÿÿ9•àþÿÿŽÿÿÿ‹àþÿÿ‹}”‹µàþÿÿƒé‹EدÏ1‹Xÿÿÿ‰D‘üÇ‘9µ0ÿÿÿ~ÇD‘ÙE¼‹EÀÙEÜÙÁƒøØÉ…ÿÿÿÙEà‹UŒ+•àþÿÿÙ•ÜþÿÿØËÙdÿÿÿˆ«ÙÊÙ•Äþÿÿ‹…àþÿÿ‹}”‹àþÿÿH‹µÄþÿÿ¯Ç‹½XÿÿÿÈ‹M”‡Ááë ‰µÄþÿÿÙ…ÄþÿÿÙÙ@Ù…ÜþÿÿÙÂØÍÙ@üÙÊØËÙÉØÂÞÁÙÀÙÍØÉÙÍØÏÙÊÞåÙËÞáÙËÙXüÙÊÙØdÿÿÿÞéÙXÈJy­ÙE¼‹…àþÿÿƒÀ;…èþÿÿ~‹…èþÿÿ‹u‹•àþÿÿB‰•(ÿÿÿ)ð‰…´þÿÿˆª‹…àþÿÿH‰…Øþÿÿët&ÙE¼Ù…Üþÿÿ‹U”‹Øþÿÿ‹½àþÿÿ‹…Xÿÿÿ¯Ê‹U”¯×ñ‰¼þÿÿ‹½¼þÿÿÙDˆüò‹M”ÙDü‹…(ÿÿÿØ̯Á‹XÿÿÿØÁÙÊðFØLüÞÂÙÊØÉÙÁØÍÙËÞáÙ\¹üÙÉØl‘üÙ\‘üØdÿÿÿØlüÙ\üÿ´þÿÿ‰lÿÿÿÙE¼Ù…Üþÿÿ‹…àþÿÿ‹uœÙ†ÙD†ÙD†üÙÂÞÎÙËØÉÙÍØÃÞÅÙËØÌÙÍØÌÙÌØdÿÿÿÙÊÞåÞãÙËÙ\†üÞâÙ†Ù\†ÿ@ÿÿÿ‹½(ÿÿÿ‰½àþÿÿ‰HýÿÿÿE„ÿ\ÿÿÿ‰6ùÿÿ‹µèþÿÿ‹E˜‰0ÄŒ[^_]ËE”Oÿ‹•Xÿÿÿ¯È4‹D²ü‹8ÿÿÿº‰D¹ü‹µ4ÿÿÿ‰T¾üÄŒ[^_]Ëu¤‹}¨‹‰•ìþÿÿ‰Ð‹7¿)ð‰Áƒéˆú÷ÿÿ‹U”Fÿ¯Âð‰…¤þÿÿ‹…¤þÿÿ‹•Xÿÿÿø‰…ÀþÿÿGÇ‚‹E”…¤þÿÿIyØé¼÷ÿÿvŠFùÿÿÝع‹E ‰L$‹• ÿÿÿ‰D$ ‰T$‹Tÿÿÿ‰L$‹•Pÿÿÿ‹…ðþÿÿ‰UЉD$‹Lÿÿÿ‰ $èüÿÿÿÙ]ÔÙEÔéôøÿÿ‹ÿÿÿ‰L$‹½ÿÿÿ‰L$‰|$ ‹•àþÿÿ‹E”‹µXÿÿÿƒê‹½àþÿÿ¯Ð –D¹ü‰D$‹µüþÿÿ‰4$èüÿÿÿé üÿÿ‹UŒ+•àþÿÿˆhÙÊÙ•Äþÿÿ‹…àþÿÿ‹}”‹àþÿÿH‹µÄþÿÿ¯Ç‹½XÿÿÿÈ‹M”‡Ááët&‰µÄþÿÿÙ…ÄþÿÿÙÙ@üÙÁØÌØÁÜËØÍÙÉÞãÞéÙÉÙXüÙÈJyÓÙE¼‹µ<ÿÿÿ‹•àþÿÿ‹MJ…ö‰•´þÿÿy ëTt&ÙE¼‹…´þÿÿ‹U”‹½àþÿÿ¯Ð‹E”¯Ç‹½XÿÿÿÊÈÙD‡üANÙD—üÙÉØËØÁÜÊØÌÙÉÞâÙÉÙ\—üØl‡üÙ\‡üy³ÙE¼‹àþÿÿ‹UœqÙŠÙDŠüÙÁÞÌÜÃÙÊØËÙËÞÌÙÉÞâÞâÙ\ŠüÙŠ‰µ(ÿÿÿé£úÿÿ‹½Dÿÿÿ‹•Xÿÿÿ‹E”‹èþÿÿ‹µDÿÿÿÙDºü‹•èþÿÿ‹½XÿÿÿÙlÿÿÿƒê¯ÂÈÙD‡øÙpÿÿÿÙD·øØL‡üé5øÿÿÙÊéØûÿÿÙÊéùþÿÿÝØÝØÝØÝØÝØéˆùÿÿ‹èþÿÿ9M€t ‹}€9½0ÿÿÿtP‹M„‹E€)MˆH‰…èþÿÿézõÿÿ‹U”‹…0ÿÿÿ‹M€‹½Xÿÿÿ¯Â‰ÂÊ‹D—ü‹8ÿÿÿ‹U€‰D‘ü‹½4ÿÿÿ¸‰D—üë°M¸u´‰ ÿÿÿ‰L$$‰µ$ÿÿÿ‰t$ ‹µèþÿÿ‹…4ÿÿÿÁæ yü‰|$ƒé‹•8ÿÿÿ‰L$<Gü‰D$ƒï‰|$‹U€‹M”¯Ê‹•Xÿÿÿ<Š‰½ÿÿÿ‰ùñAüƒé‰D$ ‹…èþÿÿ‹}”ƒè¯Ç‚‰…ÿÿÿ‰Âò‰L$züƒê‰|$‰$èüÿÿÿ‹E°‹…É„²‹•èþÿÿ}Ð9UŒª‹• ÿÿÿ‰T$‹$ÿÿÿ“‰T$‰L$‹M‹µÿÿÿ‰T$ÁáDü‰D$ ‹…ÿÿÿtü‰t$‹U‹…èþÿÿ)ÐH‰EЉ<$èüÿÿÿÙE´‹uœ‹èþÿÿÙE¸‹U¨ÙDŽøÙDŽüÙÁÙÁÙÉØÍÙÉØÌÙÊÞÍÙÊÞËÞÁÙÊÞáÙÉÙ\ŽøÙ\Žü‹2éHþÿÿ‹}¨‹7é>þÿÿ‹… ÿÿÿ‰D$‹½$ÿÿÿ‰|$‹} ‰|$‹èþÿÿ‹E”‹•Xÿÿÿ‰|$¯Á ‚ñqüƒé‰t$ ‰L$‹}Œ‹…èþÿÿ)lj}Ð}Љ<$èüÿÿÿéôþÿÿsafe minimumprecision1@?ྋ$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@0 < %p+p0p8ˆ E”l˜|˜#»…Hp  ¸ƒñÿ  0!8NV^fnu}slaqrb.f.LC7.LC6.LC5slaqrb___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_slamch_slabad_slarfg_slanhs_scopy_slanv2_srot_ ² Êïú Ï  ò ú ¦ `  6 { 'sstqrb.o/ 1189291775 1000 1000 100644 6536 ` ELFØ4( U‰åWVS쌋U‹u èüÿÿÿËM‹}‰U¬‹E‰µdÿÿÿ‹u‰`ÿÿÿ‹U¬‰½Hÿÿÿ‰µDÿÿÿ‰E¨Ç‹…À„aH„e“¸¾‰$‰D$èüÿÿÿÙxÿÿÿ‹Ù…xÿÿÿØÈÙtÿÿÿ‰t$‰ $èüÿÿÿÙlÿÿÿ‹}¬Ù…lÿÿÿػمlÿÿÿÙÉÙúÙ]ðÙEðسÙÉÙúÙ]ðÙ]ØÙEðصtÿÿÿÙ]Ћ7‰òƒêx‹…DÿÿÿǃÀJyô‰ñ‹•Dÿÿÿ~ÿÁá)ñÉÇD²ü€?‰hÿÿÿÇEœÇE”‰}€;u”Œ¾ƒ}”~‹}”¸‹`ÿÿÿ‰D¹ø‹M€9M”Š‹}”)ù‰}„ˆ|‰ø‹½dÿÿÿÁàÙî8‹½`ÿÿÿD8ü‰… þÿÿt&‹½ þÿÿÙÙáÝáßàžz„î ÙBüÙáÙúÙ]ðÙÙEðÙÉÙáÙúÙ]ðÙEðÞÉØxÿÿÿÚéßàžƒÉ ÿE„ƒÂƒ… þÿÿIy«Ý؉u„‹M„‹U”‰Ï‰UˆG9щU˜‰MŒ‰M‰}”„&ÿÿÿ¸‰ÑÁá‰D$‹•`ÿÿÿ|ü‰½ÿÿÿ“‰|$ ‹µdÿÿÿ|1ü‰|$Mì‹Eˆ‹uŒ)Ɖµ\ÿÿÿF‰uì‰L$‰$èüÿÿÿÙ]ðÙîÙEðÇE ÝáßàÝÙÙUÔžz„eÙEØÙÉÝáßàÝÙž‡ ÙEÐÚéßàž‡Ë ‹µdÿÿÿ‹M„‹}˜ÙDŽüÙD¾üÙÉÙáÙÉÙáÚéßàžv ‰M˜‹Uˆ‰U‹E˜‹M˜@9M‰…ìþÿÿŽ:¶¿‹}9}˜tu‹U˜‰þN‰ñ)щ•Øþÿÿxc‹½dÿÿÿ‰Ð‹µ`ÿÿÿÁà8|0ü´&¼'ÙBüÙÙÙÊÙáÙÉÙáÙÉØtÿÿÿÙÊÙáØÈÙÊÞÉØ…lÿÿÿÚéßàžsÿ…ØþÿÿƒÇƒÂIyËU‰•Øþÿÿ‹M9Øþÿÿ}‹µØþÿÿ¸‹½`ÿÿÿ‰D·ü‹M˜‹•dÿÿÿ9ØþÿÿÙDŠüÙpÿÿÿ„*‹½Øþÿÿ9½ìþÿÿ„M‹•hÿÿÿ9Uœ„– ÿEœƒ‹u˜Ù…pÿÿÿ‹½`ÿÿÿU¼‹dÿÿÿÙD·üÙÉØ,±ÙÉØÀÞùÙ]¼‰D$‰•ôþÿÿ‰$èüÿÿÿÙ]ð‹Øþÿÿ‹}ðÙ…pÿÿÿ‹µdÿÿÿÙîÙE¼Ùʉ}¸ØlŽü‰½¨þÿÿÙ…¨þÿÿÙËÝâßàÙËžÙá‚zÞËU˜ÙèÙË‹½`ÿÿÿ‹…Øþÿÿ‹µØþÿÿØ|—üÙË)ЉÇNO‰µèþÿÿÙUÌÙÉÞÃÙUÈÙÉÙÌþÿÿÙÉÙ]¼ÙÀˆ MÌUȉÔþÿÿE¸‰•ÐþÿÿM´‰…øþÿÿ‰üþÿÿëÙÉ‹`ÿÿÿ‹•øþÿÿÙD±üÜÊÞÉÙÉÙ]´Ù|ÿÿÿ‰T$‹…Ôþÿÿ‰D$ ‹Ðþÿÿ‰L$‹•üþÿÿ‰T$‹…ôþÿÿ‰$èüÿÿÿ9µèþÿÿt ‹E¸‹•`ÿÿÿ‰²Ù…Ìþÿÿ‹…dÿÿÿ‹M¬ÙEÈÙÉØ,°ÙD°üÙÂØÃÙEÌÙÊØãÙÉØ|ÿÿÿÙÉØÊÙËÙU¼ÙËÞÁÙÁØÉÙÉÙU¸ØÌÙËØÁÙÉÙÌþÿÿÙ°ÙÉ‹•HÿÿÿØ¥|ÿÿÿÙ]¼ÙÉÙT²üÙÉ‹‹HÿÿÿÙ•¨þÿÿ‹…¨þÿÿòN5€O‰D‘ø‰ÿÿÿÝØÝØ‹u˜¹¸)µØþÿÿº‹½ØþÿÿG‰}°‰L$$‹‰D$,‰T$(‰òÁâ‰L$ ‹½DÿÿÿD:ü‰D$‰ð‹u¬‹>‹µHÿÿÿ‰L$ ø‹‰L$|†øD2ü‰|$U°»‰T$³‰|$‰4$‰D$èüÿÿÿÙ…Ìþÿÿ‹E˜‹•dÿÿÿ‹M¼Øl‚üÙ\‚ü‹}˜‹µ`ÿÿÿ‰L¾üé_üÿÿ‹}¬‹ƒêx ‹`ÿÿÿÙîÙÝéßàžzt‹u¨ÿƒÁJyêÝØÄŒ[^_]ø€?‰ÄŒ[^_]ÃÞëéýÿÿÙ…pÿÿÿ‹U˜‹dÿÿÿÙ\‘ü‹…ìþÿÿ‹u‰E˜9ðfx‰½ìþÿÿéÜûÿÿMÌuȉL$Eĉt$}À‰|$ ‰D$‹E˜Áà<‰|$‹µ`ÿÿÿƒï‰<$D0ü‰D$èüÿÿÿÙEÈ‹}˜‹HÿÿÿÙEÌÙÉ‹U¬‰þÙT¹ü‹HÿÿÿÙÀÙÊ‹‹UÄÆÙT±ø‹…Dÿÿÿ‹uÀÙD¸üÙ¸ÙÁØËÙÍØÉÙËÞÉÙÉÞËÙÉÞãÞÁÙÉÙ¸Ù\¸ü‹dÿÿÿ¸‰t¹ü‰¹‹µ`ÿÿÿ‰D¾ü‹UƒÇ‰}˜9׋Gé"ÿÿÿÝØ‹E¬‹0;u”BùÿÿÇE¤ƒî‰µ$ÿÿÿˆ®þÿÿ‰µäþÿÿ‹Dÿÿÿ¿‰½àþÿÿ‹•dÿÿÿ‰Üþÿÿ‰•œþÿÿ‹µàþÿÿ‹…œþÿÿ‹äþÿÿ‰µ¤þÿÿÙ…ÉÙÀxF‹U¤‹…dÿÿÿ|ü‰½ þÿÿëÝ؉•¤þÿÿƒ… þÿÿBIx‹µ þÿÿÙÙÊÝâßàžwÜÝÚƒ… þÿÿBIyâ‹•àþÿÿ9•¤þÿÿ„‹¤þÿÿ‹µdÿÿÿÙ\Žü‹•œþÿÿÙ‹½Dÿÿÿ‹µ¤þÿÿ‹Tü‹Üþÿÿ‹½Dÿÿÿ‹‰D·ü‰ÿE¤ÿ…àþÿÿƒ…œþÿÿƒ…Üþÿÿÿäþÿÿÿ$ÿÿÿ‰#ÿÿÿÄŒ[^_]ËE˜H‰…ðþÿÿ´&‹u9u˜tz‹M‹E˜‹}˜)ȉÁIxj‹µdÿÿÿ‰øÁàT0ø‹µ`ÿÿÿD0ø‰… þÿÿ‰ö¼'ÙB‹µ þÿÿÙÙÉÙáÙÙÊÙáÙÉØtÿÿÿÙÊÙáØÈÙÊÞÉØ…lÿÿÿÚéßàžsƒ­ þÿÿOƒêIy¾‹};}~‹•`ÿÿÿ¹‰Lºø‹M˜‹µdÿÿÿ9ÏÙDŽüÙÈþÿÿ„¿9½ðþÿÿ„ì‹hÿÿÿ9Mœ„mÿEœƒ‹U˜Ù…Èþÿÿ‹µ`ÿÿÿ‹dÿÿÿÙD–øÙÉØl‘øÙÉM¼ØÀÞùÙ]¼‰D$‰Äþÿÿ‰ $èüÿÿÿÙ]ð‹•dÿÿÿ‹uðÙ…ÈþÿÿÙîÙE¼ÙÊØlºü‰µ¨þÿÿÙ…¨þÿÿÙËÝâßàÙˉu¸žÙá‚Þ˵`ÿÿÿÙèÙË‹U˜‹…ðþÿÿØ|–øÙË)ø‰þ‰…@ÿÿÿÙUÌÙÉÞÃÙUÈÙÉÙ°þÿÿÙÉÙ]¼ÙÀˆMÌUȉ¼þÿÿE¸‰•¸þÿÿM´‰…Àþÿÿ‰´þÿÿët&ÙÉ‹`ÿÿÿ‹•ÀþÿÿÙD±üÜÊÞÉÙÉÙ]´Ù¬þÿÿ‰T$‹…¼þÿÿ‰D$ ‹¸þÿÿ‰L$‹•´þÿÿ‰T$‹…Äþÿÿ‰$èüÿÿÿ9þt ‹E¸‹•`ÿÿÿ‰D²øÙ…°þÿÿ‹…dÿÿÿ‹U¬ÙEÈÙÉØl°üÙ°ÙÂØÃÙEÌÙÊØãÙÉجþÿÿÙÉØÊÙËÙU¼ÙËÞÁÙÁØÉÙÉÙU¸ØÌÙËØÁÙÉÙ°þÿÿÙ\°üÙÉ‹HÿÿÿØ¥¬þÿÿÙ]¼ÙÉÙT±üÙÉ‹‹HÿÿÿðFÙTøÿ@ÿÿÿ‰ÿÿÿÝØÝØ‹u˜¹¸º)þF‰u°‰L$$‹‰D$,‰T$(½‰L$ ‹µDÿÿÿD2ü‰D$‹E¬‹0÷‹µHÿÿÿ‰L$ D¾ø|2ü‰D$“E°‰|$³»‰T$‰t$‰<$‰D$èüÿÿÿÙ…°þÿÿ‹E˜‹dÿÿÿ‹U¼ØlüÙ\ü‹µðþÿÿ‹½`ÿÿÿ‰T·üé”üÿÿÞëéáýÿÿÙ…Èþÿÿ‹E˜‹•dÿÿÿÙ\‚ü‹ðþÿÿ‹}‰M˜9ùŒ¢‹½ðþÿÿO‰½ðþÿÿéTüÿÿEÄ}̉D$‰È‰|$Áà 0qüƒéUȉt$}À‰|$ ‰T$‹•`ÿÿÿ‰ $|ø‰|$èüÿÿÿÙEÈ‹M˜‹…DÿÿÿÙEÌÙÁ‹uÀÙDˆø‹}ÄÙDˆüÙÁØÌÙËØÉÙÌÞÉÙÉÞÌÙÊÞáÙÉÞÂÙ\ˆüÙ\ˆø‹•dÿÿÿ¸‰tŠø‰|Šü‹µ`ÿÿÿ‰DŽø‹}ƒé‰M˜9ùŒßyÿé<ÿÿÿÝØÇE ‹M¨º‰T$(‹E¬“‰L$$Mè‰|$}Ô‰D$ ‰•Xÿÿÿ‰T$‰uèu؉L$‰µÿÿÿ‰t$³‰½ ÿÿÿ‰|$ »‰t$‰t$‰<$èüÿÿÿ‹U¨¸‹M¬‰D$(‰T$$‰L$ ‹…ÿÿÿ‰D$‹•XÿÿÿEä‰T$‹\ÿÿÿ‰Mä‰D$‹•ÿÿÿ‰T$‹ ÿÿÿ‰t$‰t$‰L$ ‰<$èüÿÿÿé5ôÿÿÇE ‹U¨¸‰D$(‹}¬ƒ‰T$$‰|$ ‹}˜‹µdÿÿÿÁçL7ü‰L$‰…Tÿÿÿ‰D$‹U˜Eà‹u„)Ö‰ñ‰µPÿÿÿUÐA‰MàuÔ‹‰D$‰•ÿÿÿ‰T$‰µÿÿÿ‰t$ ³‰t$‰t$‰Lÿÿÿ‰ $èüÿÿÿ‹U¨¸‹M¬‰D$(‰T$$‰L$ ‹…`ÿÿÿTü‰T$EÜ‹Tÿÿÿ‰L$‹½Pÿÿÿ‰}܉D$‹•ÿÿÿ‰T$‹ÿÿÿ‰t$‰t$‰L$ ‹½Lÿÿÿéôþÿÿƒ} tMƒ} „C‹hÿÿÿ9Mœ÷ÿÿ‹U¬‹2é›ñÿÿÝØÝØéLòÿÿÝØ‹M„‹½`ÿÿÿÇDüé4òÿÿÝØÝØé+ùÿÿ‹U¨¹‹}¬‰L$(‹‰T$$‰|$ ‹}ˆ‹µdÿÿÿÁçD7ü‰D$‰<ÿÿÿ‰L$‹UˆMÜ‹uŒ)Ö‰ð‰µ8ÿÿÿUÔ@‰EÜu؃‰L$‰•ÿÿÿ‰T$‰µ ÿÿÿ‰t$ ³‰t$‰t$‰…4ÿÿÿ‰$èüÿÿÿ‹U¨¹‹E¬‰L$(‰T$$‰D$ ‹`ÿÿÿTü‰T$‹½<ÿÿÿUà‰|$‹…8ÿÿÿ‰Eà‰T$‹ÿÿÿ‰L$‹½ ÿÿÿ‰t$‰t$‰|$ ‹µ4ÿÿÿ‰4$èüÿÿÿé½þÿÿ‹E¨º‹u¬‰T$(“‰D$$‰t$ ‹uˆ‹½dÿÿÿÁæL>ü‰L$‰•0ÿÿÿ‰T$‹EˆUä‹}Œ)ljù‰½,ÿÿÿEÔA‰Mä}Ћ‰T$‰…ÿÿÿ‰D$‰½ÿÿÿ‰|$ »‰|$‰|$‰(ÿÿÿ‰ $èüÿÿÿ‹E¨º‹M¬‰T$(‰D$$‰L$ ‹•`ÿÿÿtü‰t$Uè‹…0ÿÿÿ‰D$‹,ÿÿÿ‰Mè‰T$‹µÿÿÿ‰t$‹…ÿÿÿ‰|$‰|$‰D$ ‹µ(ÿÿÿéûþÿÿesibvrfg€?@@‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@· p %ø+ø4ø 0 p >F Sz Š #C“0ð  Ýñÿ 2  FKPU  Zbiq·y ¦®¶¾ÆÍÕsstqrb.f__g77_forceload_0.0__g77_forceload_1.1__g77_forceload_2.2.LC0.LC3.LC6.LC7xerbla_sswap_slaset_sstqrb___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_slamch_slanst_slapy2_slartg_slasr_slaev2_slascl_ c y… Ÿ´ Ê * ]Û ö . G Q aR A = þ B O U i  ¯ å õ d… Î ì Ð  7 M¶Ð  7 Mssortc.o/ 1189291775 1000 1000 100644 2664 ` ELFÈ4( U‰åWVSƒì\‹U ‹MèüÿÿÿËE‹}‰Uì‹U‰MЋu‰E̹‰Uè‰}ä‹:º‰L$ ‰øÁè‰T$ÇÑÿ‰}܃‰D$‰4$èüÿÿÿ…À… ‹uÜ…ö„ö‹EÜ‹}è‹MÜ÷ЉMà‰EԈƋ}àv¼'‹UÜ)×…ÿˆ ‹MÌ4½‹UÐÖ‰D$‰4$èüÿÿÿÙ]Ø‹EÜ‹MÌ4µ‰T$‹MÐȉ$èüÿÿÿÙ]ðÙEðÙEØÚéßàžvK‹EЋ¸‰Á‹°‰¹‰±‹EÌ‹¸‰Á‹°‰¹‹E쉱‹…Ò„oÿÿÿ‹M䋹‹±‰¹‰±‹UÜ)×…ÿ‰`ÿÿÿÿEàÿMÔ‰:ÿÿÿ‹}ÜÁï}ÜÑ}Ü‹uÜ…ö… ÿÿÿƒÄ\[^_]É4$¸º‰D$ ‹‰T$‰L$èüÿÿÿ…À…ø‹uÜ…ötÅ‹MÜ‹UÜ‹}è÷щUĉMȈNj}ĉö¼'‹EÜ)Ç…ÿˆ¢‹MÌ4½‹UÐÖ‰D$‰4$èüÿÿÿÙ]À‹EÜ‹MÌ4µ‰T$‹MÐȉ$èüÿÿÿÙ]ðÙEðÙEÀÙÉÚéßàžvK‹EЋ¸‰Á‹°‰¹‰±‹EÌ‹¸‰Á‹°‰¹‹E쉱‹…Ò„mÿÿÿ‹M䋱‹¹‰¹‹E܉±)Ç…ÿ‰^ÿÿÿÿEÄÿMȉ9ÿÿÿ‹}ÜÁï}ÜÑ}Üéÿÿÿ‰4$¸º‰D$ ‹‰T$‰L$èüÿÿÿ…À…œ‹uÜ…ö„þÿÿ‹MÜ‹UÜ‹}è÷щU¼‰M¬xk‹M¼‹EÜ)Á…ÉxW‹UÜ‹}Ð4ÙÙ·ÙÉÝáßàž†ÙÉ‹}ÐÙÙ·‹}Ì‹·‹‰‰·‹}ì‹…Àt¸‹}ä‹·‹‰‹E܉·)Á…Éy©ÿE¼ÿM¬y•‹uÜÁîuÜÑ}Üédÿÿÿ‰4$º‹‰T$ ¿‰|$‰L$èüÿÿÿ…À…¯‹EÜ…À„Õýÿÿ‹uÜ‹}Ü‹Mè÷Ö‰}¸1‰u¬xc‹M¸‹UÜ)Ñ…ÉxO‹UÜ‹}Ð4ÙÙ·Ýáßàžva‹}ÐÙÙ·‹}Ì‹·‹‰‹E쉷‹8…ÿtÀ‹}ä‹‹·‰‰·‹UÜ)Ñ…Éy±ÿE¸ÿM¬y‹uÜÁîuÜÑ}ÜélÿÿÿÝØÝØÿE¼ÿM¬éÿÿÿÝØÝØÿE¸ÿM¬ëÒ‰4$º‹‰T$ ¿‰|$‰L$èüÿÿÿ…À…¦‹EÜ…À„úüÿÿ‹uÜ‹}Ü‹Mè÷Ö‰}´1‰u¬xu‹M´‹UÜ)Ñ…Éxa‹UÜ‹}Ì4ÙÙ·ÙÉÙáÙÉÙáÙÉÚéßàžvA‹}Ћ‹·‰‰·‹ẺNjˆ‹°‰‰·‹}ì‹…Àt®‹}ä‹‹·‰‰·‹UÜ)Ñ…ÉyŸÿE´ÿM¬ë‰‹uÜÁîuÜÑ}ÜéZÿÿÿ‰4$º‹ ‰T$ ¿‰|$‰L$èüÿÿÿ…À…3üÿÿ‹EÜ…À„(üÿÿ‹MÜ‹}Ü‹uè÷щ}°‰Ï>xo‹u°‹UÜ)Ö…öx]‹UÜ‹EÌ Ù°ÙˆÙÉÙáÙÉÙáÚéßàžv?‹EЋ°ÙˆÙ°‰ˆ‹EÌ‹°ÙˆÙ°‰ˆ‹Uì‹…Àt²‹E䋰وٰ‰ˆ‹UÜ)Ö…öy£ÿE°Oë‹uÜÁîuÜÑ}ÜéaÿÿÿLMSMLRSRLISI‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@Ü Ø %+0 8(_,o,#Ox¨à  ˆ Mñÿ Ü)?Essortc.fssortc___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_cmpslapy2_  W c Ç î ‹ ˜ ÷  ¯ ¼ n „ I _  1 ssortr.o/ 1189291775 1000 1000 100644 1868 ` ELF4( U‰åWVSƒìL‹M‹} èüÿÿÿËE‹U‰Mì‹u‰}ð‹}ì‰Eè‰U䋺‰T$ ‰4$‰ÈÁè<¹ƒ‰L$Ñÿ‰D$èüÿÿÿ…À……ÿtw‰}à‹Uì‰þ÷Ö2‰uÜxY‹Mà´&¼')ù…Éx:‹Uè49يٲÝáßàžvD‹Uè‹Eðيٲ‹…ÒtÕ‹E䋈ٰو)ù…ɉ°yÆÿEàÿMÜy§‰ùÁéÏÑÿ…ÿu‰ƒÄL[^_]ÃÝØÝØÿEàÿMÜë݉4$¹º‰L$ ƒ‰T$‰D$èüÿÿÿ…À…ˆ…ÿt¼‰}Ì‹Eì‰þ÷Ö0‰uØx^‹MÌv)ù…ÉxJ‹Eè49‹ˆ‰UÀÙ°ÙEÀÙÁÙÉÙáÙÉÙáÚéßàžv:‹EèÙˆ‰°‹Uð‹…ÀtÅ‹E䋈ٰو)ù…ɉ°y¶ÿEÌÿMØy¢‰ùÁéÏÑÿë‚ÝØÿEÌÿMØëé‰4$¹º‰L$ ƒ‰T$‰D$èüÿÿÿ…Àuw…ÿ„ÿÿÿ‰}È‹Eì‰þ÷Ö0‰uÔxS‹MÈ)ù…ÉxB‹Uè49يٲÙÉÝáßàž†ðÙÉ‹Eè‹Uðوٰ‹…ÀtÍ‹E䋈ٰو)ù…ɉ°y¾ÿEÈÿMÔy­‰ùÁéÏÑÿ뉉4$¹º‰L$ ƒ‰T$‰D$èüÿÿÿ…À…mþÿÿ…ÿ„eþÿÿ‰}Ä‹Eì‰þ÷Ö0‰uÐx]‹MÄ)ù…ÉxL‹Eè49‹ˆ‰UÀÙ°ÙEÀÙÁÙÉÙáÙÉÙáÙÉÚéßàžvP‹EèÙˆ‰°‹Uð‹…ÀtËE䋈ٰو)ù…ɉ°y´ÿEÄÿMÐy£‰ùÁéÏÑÿé|ÿÿÿt&ÝØÝØÿEÈÿMÔé0ÿÿÿÝØÿEÄÿMÐëÓSASMLALM‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ üP %\+\0\8d_hoh#‹xäÐ  ´Eñÿ )?ssortr.fssortr___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_cmp  O ^   À Í _ l sstatn.o/ 1189291775 1000 1000 100644 1172 ` ELF<4( èüÿÿÿÁU‹º‰åÇÇ@Ç@Ç@ Ç@‰P0‰P4‰P8‰P<‰P@‰PD‰PH‰Pt‰Pp‰Px‰Ph‰Pl]Ë $ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.gnu.linkonce.t.__i686.get_pc_thunk.cx.note.GNU-stack.comment@a | %¤+¤0¤W¨g¨#Ëpô   eñÿ  #( |òÿ0a8Osstatn.ft0.0t1.1t2.2t3.3t4.4t5.5timing_sstatn___i686.get_pc_thunk.cx_GLOBAL_OFFSET_TABLE_ sstats.o/ 1189291775 1000 1000 100644 1172 ` ELF<4( èüÿÿÿÁU‹º‰åÇÇ@Ç@Ç@ Ç@‰P‰P‰P‰P ‰P$‰P(‰P,‰Pt‰Pp‰Px‰Ph‰Pl]Ë $ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.gnu.linkonce.t.__i686.get_pc_thunk.cx.note.GNU-stack.comment@a | %¤+¤0¤W¨g¨#Ëpô   eñÿ  #( |òÿ0a8Osstats.ft0.0t1.1t2.2t3.3t4.4t5.5timing_sstats___i686.get_pc_thunk.cx_GLOBAL_OFFSET_TABLE_ snaitr.o/ 1189291775 1000 1000 100644 9044 ` ELFø4( U‰åWVSìÌ‹U‹EèüÿÿÿËu‹}‰UÄ‹U(‰EÀ‹E,‰uÌ‹M ‰}¼‹u ‰U˜‹}0‰E°‹U<‰MÈ‹M$‰u¸‹u4‰}Œ‹}°‰U”‹E@‰M´‹M8‰u¬‹7‰M¨‰E¤‰u ‹M¬‹‰Uœ‹ƒ…À…—‹MÌ‹1…ö„ ‹»$…ÿ…,‹ƒ(…À„Ó³“‰µhÿÿÿ‰•|ÿÿÿ‹}ȶ‰ÁùƒøŒ‰EØ)Á‰Â‰ÎNˆI}è‰}„»rë4ÝÚÙÉÙÉÚéßàžr‹MœBÿ¯ÁЋUŒÇ‚‹UØBN‰Â‰E؈‹MœBÿ¯Á‹MŒÐÙDü‹EœÙá¯ÂÐÙÙáÞÁÙîÙÉÝáßàÝÙžt7Ùƒ\‹MœBÿÞɯÁ‹MŒÙƒXÐÙÙÊÝáßàÙÊžÙá‚lÿÿÿÝÙéiÿÿÿzÇÝØ‹Uĸ‰D$‹M”‹‹U¬‹M¼‰T$ ‹UÀ‰D$‹EŒ‰D$‹‹ ‹U„ȉEè‰T$‰<$èüÿÿÿÙ]ì‹UØÙEìésÿÿÿ‹“d³t¿/Ù]ÔMЃ‰UЉt$‹³‰|$‰L$~‰|$ ‰D$‰4$èüÿÿÿ‰|$ ‹£º‰L$‹»D‰T$‹EœO‹UŒ¯øƒD º‰L$‰…dÿÿÿ‰D$‰4$èüÿÿÿé0öÿÿÝØ‹UÄEÜ¿‰|$(‰E€‹»D‰D$$‰T$ ‹M O‹u˜¯ù‹Mľ‹}´‰D$‹•tÿÿÿ³‰L$‰T$‰u‰t$u؉|$ »»‰t$‰t$‰<$èüÿÿÿ¸‰D$(‹U€‹ƒ0‰T$$‹UĉT$ ‹M”Dü‰D$‹…tÿÿÿ‰T$‹U´‰D$‹M‰T$ ‰t$‰L$‰t$‰<$èüÿÿÿé…üÿÿ“‹³0‹M¸‰T$‹}”‰T$‰L$D·ü‹}ĉD$ ‰<$èüÿÿÿÙ]ìÙEìÙáÙúÙ]ì‹u´ÙEìÙéÔôÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹MÈØ« Ø@lÙXl¶é†ôÿÿ³Ä¹(»D‰t$‹³‰L$V‰•lÿÿÿ‰|$»‰T$ ‰|$‰4$èüÿÿÿ¸)‹ì‰D$‹E´‰L$‹•lÿÿÿ‰D$‰|$‰T$ ‰4$èüÿÿÿé ÷ÿÿÿF¿‰»(‹u¨‹“4‹ƒ0‹M̉‰FÇÄÌ[^_]Ë»ÿG‹}¸‹Mˆ‹³4‰L$‹U”‰L$‰|$D²ü‹uĉD$ ‰4$èüÿÿÿ럋µhÿÿÿ‹»0‹M¸‰t$‹U”‰t$‰L$Dºü‹}ĉD$ ‰<$èüÿÿÿÙ]ìÙEìÙáÙúÙ›déòÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹MÈØ« Ø@lÙXl¶é¿ñÿÿ‹U¸ƒ‹MĉD$‰T$‰ $èüÿÿÿéAþÿÿ‹…hÿÿÿ‹u¸‹MĉD$‰t$‰ $èüÿÿÿë…ÝØéCöÿÿ‹³ÿF‹u¸‰|$‹M”‰|$‹ƒ4‰t$‹}ÄTü‰T$ ‰<$èüÿÿÿ‹U¨‹‹4‹ƒ0‹ủ ‰BÇé¡úÿÿ³ ‰4$èüÿÿÿÙƒ‹ƒ‹MÈØ« Ø@lÙXl¶ |òÿFM `òÿT[cjrz‰˜ž¥snaitr.ft0.0t1.1t2.2t3.3t4.4t5.5first.6orth1.7orth2.8rstart.9step3.10step4.11ierr.12ipj.13irj.14ivj.15iter.16itry.17j.18msglvl.19betaj.20ovfl.21rnorm1.22smlnum.23ulp.24unfl.25wnorm.26.LC4.LC6.LC1.LC11.LC13.LC8.LC15snaitr___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_sgemv_arscnd_timing_saxpy_debug_ivout_sgetv0_scopy_slamch_slabad_sscal_slanhs_svout_slascl_sdot_snrm2_smout_- .} ˜ ¦ ´ $º Þ   %, = &N c o/ˆ ± ' Ö/Ü õ ÿ 0  0H a (g |1„  ™ ­ ³ %½ $Ù ã ÿ &// O '` }/‡ ž Ä2Ê Ð Ø0   # -33 $N4T a (j ‡ • £ ± )· Ã Ï à æ ï ô0ú 1   # 3 T Z h s }3ƒ $ž4¤ ®1´ ¿ )È Ô è V5h v € Œ ’  0¦ ¬1µ Ò Ú0à è1î ÷ $  + 76E0g ’6¢ ¬0²3Â Ë Ó Ü î õ      ' - 7 ?7T Z &` e8p |7‹ •  £ ´ ß6  $ E 6K p — 9£ Á 9Ç 1Ò Ø â 0î  , 65 ; A g ˆ 6™ ¡ 0§ ³ ï [ o Ô :è î ÿ * 3' ;1 @ T m ;Œ · &Ó ã <õ 7 <B $H m = • 0› ¡ 1ª ¾ É Ó 3ê $ú 4 *;= F L k1z œ6ª Ï=ß ê ò0ø þ1  $1>R>a1x 6˜ ž · ¿0Å Ë1Ô ë $ñ =& 2 ? Q3?š1¥ ¬   % *=;K $^>snapps.o/ 1189291775 1000 1000 100644 8464 ` ELFH4( U‰åWVSì ‹U‹u èüÿÿÿËM‹E‰Uˆ‹U‰u„‹u ‰M€‹M$‰…|ÿÿÿ‹}‰•øþÿÿ‹E(‰µtÿÿÿ‹U0‰ ÿÿÿ‹M<‰½xÿÿÿ‹},‰…pÿÿÿ‹…tÿÿÿ‰•ÿÿÿ‹u8‰üþÿÿ‹U4‰½lÿÿÿ‹8‰•hÿÿÿ‰µdÿÿÿ‰½`ÿÿÿ‹µpÿÿÿ‹ƒ‹…À‰\ÿÿÿ‹‰•Xÿÿÿ…Y³‰4$èüÿÿÿ‹³‹M€‹}„‹F8‹‹½ÿÿÿ‰…Tÿÿÿ‹¹‰L$Ћ‰EÄ‹…hÿÿÿ“‰|$»‰D$Eĉ•Ôþÿÿ‰T$‰Ðþÿÿ‰L$ ‰…ôþÿÿ‰D$‰D$‰<$èüÿÿÿ‹U€‹…À„’ ÇEÀ1ÿ“‰½PÿÿÿH‰•Èþÿÿ‰…Dÿÿÿˆ ‰µ<ÿÿÿF“‰…LþÿÿE¸MÀ‰•@ÿÿÿU¼»‰•ìþÿÿ‹•Lþÿÿ³<‰…èþÿÿ‹…<ÿÿÿ‰ðþÿÿ‹d‰•˜þÿÿ“e‰½8ÿÿÿ»„‰½œþÿÿ‹½ðþÿÿ‰…þÿÿ‹…˜þÿÿ‰µ4ÿÿÿu´‰ þÿÿ‹°‰µ”þÿÿ³Ü‰ŒþÿÿM°‰½ˆþÿÿ»û‰•„þÿÿU¬‰µÿÿÿu¨‰…ÿÿÿE¤‰äþÿÿM ‰½ÿÿÿ}œ‰•àþÿÿU˜‰µ€þÿÿu؉…|þÿÿE܉xþÿÿ‹‰½tþÿÿ}Œ‰•pþÿÿ“‰µlþÿÿuЉ…hþÿÿE”‰dþÿÿM‰½`þÿÿ‰•\þÿÿ‰µXþÿÿ‰…Tþÿÿ‰Pþÿÿƒ½Tÿÿÿ‹UÀ‹…|ÿÿÿ‹½xÿÿÿ‹Lü‹t—ü‰M¼‰u¸] ‹Pÿÿÿ…É…b ‹E€‹09ÖŽ ÙE¸ÙîÙÉÙáÚéßàž†ü ¾‰µPÿÿÿÇE°‹MÄ‹u°‰Ï)÷‰u´‰þNˆ‰‹…œþÿÿ‹˜þÿÿ‹•þÿÿ‰…0ÿÿÿ‹…Œþÿÿ‹½ þÿÿ‰,ÿÿÿ‰•(ÿÿÿ‰…$ÿÿÿ‹„þÿÿ‰ÿÿÿëÝÚÙÉÙÉÚéßàžƒ’BN‰E´ˆé ‹U´‹\ÿÿÿBÿ¯Á‹ ÿÿÿÐÙDü‹…\ÿÿÿÙá¯ÂÐÙÙáÞÁÙîÙÉÝáßàÝÙž„Ùƒ ‹\ÿÿÿBÿÞɯÁ‹ ÿÿÿÙƒÐÙÙÊÝáßàÙÊžÙá‚lÿÿÿÝÙÙÉÚéßàž‚nÿÿÿ‹½Tÿÿÿ…ÿŽÈ‹½”þÿÿº*‹0ÿÿÿ‰T$‹µ(ÿÿÿ‹…,ÿÿÿ‰|$‹½Èþÿÿ‰L$‰4$‰|$‰D$ èüÿÿÿ‰|$‹$ÿÿÿº+‰T$‹µˆþÿÿ‹½(ÿÿÿ‰L$‹…,ÿÿÿ‰t$‰<$‰D$ èüÿÿÿ‰<$º‹…,ÿÿÿ‰T$‹U´‹µ\ÿÿÿ‰D$ ‹ÿÿÿBÿ¯Æ‹µÈþÿÿ‰L$‹ ÿÿÿЉt$‰T$èüÿÿÿ‹U´‰U¬‹\ÿÿÿzÿ‹µ ÿÿÿ¸¯ù׉¾ƒ½TÿÿÿŽ°‹µÿÿÿ¸‹½äþÿÿ‰D$‹ÿÿÿ‰t$ ‹µÈþÿÿ‰|$‹½<ÿÿÿ‰L$‰t$‰<$èüÿÿÿ‰t$º‹…ÿÿÿ‰T$‹ÿÿÿ‹•àþÿÿ‰D$‰L$ ‰T$‰<$èüÿÿÿ‹U°‹u¬9òu>‹MÄ~‰}°9΋u°‰Ï)÷‰u´‰þN‰wýÿÿ‰M¬ƒ½TÿÿÿPÿÿÿ‹U°‹u¬9òtÂz9÷„¥ ‹M¸Ù\ÿÿÿBÿ¯Ç‹½ ÿÿÿÐÙ‡ÙD‡üÙɉ$þÿÿÙ þÿÿÙ…$þÿÿÙáÙÊÝêßàÝÙž‚– Øe¼‰ñ)ÑÙ… þÿÿÙÉI‰U´‰ ÿÿÿÙ]˜Ù]œ¶ˆGÿÿÿ‹€þÿÿ‹½|þÿÿ‹…xþÿÿ‰L$‹µtþÿÿ‹•pþÿÿ‰|$ ‰D$‰t$‰$èüÿÿÿ‹M´;M°~;ÙE¨ÙîÝéßàžv Ùà€u£€€u§€ÙU¨‹½\ÿÿÿqþ‹• ÿÿÿ¯÷΋M´Ù\²üDz‹EĉÆ)ÎxaÙE ‹•\ÿÿÿ‹…\ÿÿÿÙE¤¯Ñ‹}´)Âë‰ù ‹ ÿÿÿÙDüÙÙÁÙÁÙÉØÍÙÉØÌÙÊØÍÙËØÌÙÉÞÂÞêÙ\üÙ‹\ÿÿÿÊNyÂÝØÝØ‹M´‹U¬A9Ð~‰Ð‰Æ¿NxoÙE ‹U´ÙE¤‰•¤þÿÿ다þÿÿ‹…\ÿÿÿQÿ¯Ð‹… ÿÿÿúÙDü‹…\ÿÿÿÙÀ¯Á‹ ÿÿÿØËÙÉØÊøGÙDüNÙÀØÌÙÉØÍÙËÞÁÙÊÞáÙ\üÙ\‘üy©ÝØÝØ‹M´‹uÀ‰È‹UÄð9Ð~‰Ð‰Æ¿NxvÙE ‹U´ÙE¤‰•¨þÿÿë ´&‹¨þÿÿ‹…XÿÿÿQÿ¯Ð‹…ÿÿÿúÙDü‹…XÿÿÿÙÀ¯Á‹ÿÿÿØËÙÉØÊøGÙDüNÙÀØÌÙÉØÍÙËÞÁÙÊÞáÙ\üÙ\‘üy©ÝØÝØ‹M´‹u¬~ÿ9Ï~!‹½\ÿÿÿAÿ¯Ç‹½ ÿÿÿÈ‹‡‰U˜‹T‡‰Uœÿ ÿÿÿA‰E´éÆýÿÿ‹u„‹‹…\ÿÿÿqÿ‹½ ÿÿÿ¯ð1Ù—Úéßàž‡` ÇE´‰ÎNˆøƒ!}ȉ…Dþÿÿë‹U„‹ ‰|$º‹…Èþÿÿ‰T$,‹•üþÿÿ‰D$(‹…Ðþÿÿ‰T$$‹•Èþÿÿ‰D$ ‹…Xÿÿÿ‰T$‹U´)ѯÁ‹ÿÿÿ‰D$‹tÿÿÿ‹…øþÿÿ‰L$‹Ôþÿÿ‰D$‹EĉL$ ‹Dþÿÿ)ЋUˆ@‰ $‰EȉT$èüÿÿÿ‹…Èþÿÿ‹U´‹`ÿÿÿ‰D$‹EÄ)ЯÁ‹•øþÿÿ ‚‰L$ ‹•Èþÿÿ‹…üþÿÿ‹Mˆ‰T$‰D$‰ $èüÿÿÿÿE´N‰ÿÿÿ‹}„‹¾‹…øþÿÿ‹½tÿÿÿ‰t$‹uÄ‹•øþÿÿ‰D$)΋`ÿÿÿ‰|$‹E„‰|$¯ñ‹Mˆ‰D$<²“"‰|$ ‰L$‰$èüÿÿÿ‹u„Ù\ÿÿÿ‹‹µ ÿÿÿBÿ¯Ç ÙŽÚéßàž‡« ‹XÿÿÿJ‹½Èþÿÿ‹…ÿÿÿ¯Ñ‹Mĉ|$ ‹½lÿÿÿ4‹UˆDŽü‰|$‰D$‰$èüÿÿÿ‹u„Ùî‹\ÿÿÿ‹‹µ ÿÿÿBÿ¯Á ÙŽÚéßàž‡ÿ ƒ½TÿÿÿŽ¾(‹M„»$‰t$‹³‹•Xÿÿÿ‰|$~‰|$ ‹‹ÿÿÿ‰4$H¯Â‹MÄDŠü‰D$‹•Èþÿÿ‰T$èüÿÿÿ‰|$ ‹U„¹%‰L$ƒL‹\ÿÿÿ‰D$‹‰4$Pÿ¯Ñ‹ ÿÿÿЋ•Èþÿÿ‰D$‰T$èüÿÿÿ‰|$ ¹-‹U„‰L$‹Èþÿÿƒt‰D$‰T$‰L$‰4$èüÿÿÿƒ½Tÿÿÿ~>‰|$º6ƒ¤‰T$‹pÿÿÿ‹• ÿÿÿ‰D$‹E„‰L$‰T$ ‰D$‰D$‰4$èüÿÿÿ³‰4$èüÿÿÿÙƒ‹»Ø«ØGDÙ_DÄ [^_]ÊÞ÷ÿÿÝ؉<$‹dÿÿÿº‰T$‹…pÿÿÿ‹• ÿÿÿ‰L$‹MÀ‰D$ ‹EĉT$‹•Xþÿÿ)È@‰T$‰EÐèüÿÿÿÙ]Ô‹U´ÙEÔé‰÷ÿÿ1ÿÿDÿÿÿr‰½Pÿÿÿ‰uÀ‰Löÿÿ‹E„º‹‰•Hþÿÿ‰ÏOˆ«Uȃ‰•Àþÿÿ‹•Xÿÿÿ‰…Äþÿÿ‹…ÿÿÿuЉµÿÿÿ‹µ ÿÿÿM̉ÿÿÿÁâ1ɉ¬þÿÿÐÙ¼þÿÿ‹…\ÿÿÿ‰•¸þÿÿÁàƉµ´þÿÿ‰…°þÿÿë1ÿ…Hþÿÿ‹•\ÿÿÿ‹°þÿÿ•¬þÿÿ‹…¸þÿÿ´þÿÿ…¼þÿÿOˆê‹¬þÿÿ‹µHþÿÿ‹• ÿÿÿñÙŠÙÉÝáßàÝÙžv­ÝØ‹…pÿÿÿ‹µ ÿÿÿ‰D$ Ž‹EĉT$‹Hþÿÿ‹µÄþÿÿ‹•ÿÿÿ)È@‰$‰t$‰EÐèüÿÿÿ‰t$‹…Èþÿÿ‹UÄ‹´þÿÿ‰D$ ‹…Hþÿÿ‰L$ƒÀ9Ð~‰Ð‰EÌ‹•ÿÿÿ‰$èüÿÿÿ‹Èþÿÿ‹…¼þÿÿ‹µÄþÿÿ‰L$ ‹U€‰D$‹…Hþÿÿ‰t$‹ ‹UÄÈ@9Ð~‰Ð‰EÈ‹µÀþÿÿ‰4$èüÿÿÿÙîéåþÿÿ9Ö…õÿÿÙE¸ÙîÙÉÙáÚéßàž†óôÿÿ‹U„ÿ‹UÀÿDÿÿÿré$þÿÿ‹µLþÿÿº‹½ðþÿÿ‰T$‹…@ÿÿÿ‰t$ ‹µÈþÿÿ‰|$‹½<ÿÿÿ‰t$‰D$‰<$èüÿÿÿ‰t$¹#‹•8ÿÿÿ‰L$‹…Lþÿÿ‹ìþÿÿ‰T$‰<$‰L$‰D$ èüÿÿÿº(‹…4ÿÿÿ‹Lþÿÿ‰T$‹½èþÿÿ‹•<ÿÿÿ‰D$‹µÈþÿÿ‰L$ ‰$‰|$‰t$èüÿÿÿ‹UÀéêóÿÿ¹ ƒÚ»‰L$¾ ‰$èüÿÿÿÙ]Ô“$ÙEÔ‰|$1ÿ‰$Ù“$ػٛèüÿÿÿ‰t$‹æ‰ $èüÿÿÿÙ]Ô‹EˆÙEÔ‰»ÛÙÉÙ“ ÞùØ‹$Ù›éñÿÿ‹MÄé6öÿÿ‹M¸Ùî‰$þÿÿÙ…$þÿÿÙáÝéßàž†BöÿÿÝØ‹MÄ~‰}°9ÎŒòõÿÿélþÿÿ‹½\ÿÿÿ‹ ÿÿÿ‹…èþÿÿ¯ú×ÙD¹üÙLÿÿÿÙ¹ÙE¼ØÀÙÉÙHÿÿÿÙÉ‹t¹‹½ìþÿÿÙ(þÿÿÙ]¤‰<$‰D$èüÿÿÿÙ…(þÿÿÙɉuà‹u¬Ù]Ô‹U°ÙÀÙE¤‰ñ)ÑÙEÔÙʉÏØáÙʉU´OØÈÙÊØËÙËØ…HÿÿÿÙËÞÂÞêص þÿÿØ…LÿÿÿÙÉÙ]ÜÙ]؈0õÿÿMÐE”‰ÌþÿÿU‰…Øþÿÿ‰•Üþÿÿ‹E´)ÆV‰Uƒú~ÇE‹µØþÿÿ‹•hþÿÿ‹…Èþÿÿ‰t$‹lþÿÿ‹µÜþÿÿ‰T$‰D$ ‰L$‰4$èüÿÿÿ‹U´;U°~3‹\ÿÿÿrþ‹Eدñ ‹µ ÿÿÿ‰DŽü‹E¬ÇŽH9Ð~ÇDŽÇEØ€?‹…pÿÿÿ¹‰L$$‹\ÿÿÿ‹µdÿÿÿ‰D$Bÿ¯Á‰t$ ‹µ ÿÿÿ †‹…Øþÿÿt‘ü‹Èþÿÿ‰t$‹µlþÿÿ‰D$‹EĉL$‹Ìþÿÿ)Љt$ ‹•dþÿÿ@‰L$‹µÜþÿÿ‰EЉ$‰t$èüÿÿÿ‹M´‹U¬A‰EŒ9Ð~‰UŒ‹µpÿÿÿ¸‹•dÿÿÿ‰D$$‹…\ÿÿÿ‰t$qÿ¯ð‰T$ ‹• ÿÿÿ‹…Øþÿÿ ²‹µÈþÿÿ‰L$‹•Üþÿÿ‰D$‹lþÿÿ‹…`þÿÿ‰t$‹µ\þÿÿ‰L$ ‰T$‰4$‰D$èüÿÿÿ‹•dÿÿÿ¹‹µXÿÿÿ‰L$$‹…hÿÿÿ‹ÿÿÿ‰T$ ‹U´‰D$J¯Ö‹µTþÿÿ‘‹•Èþÿÿ‰D$‹Pþÿÿ‹…lþÿÿ‰µØþÿÿ‰t$‹µôþÿÿ‰T$‹•\þÿÿ‰t$‰D$ ‰$‰Üþÿÿ‰L$èüÿÿÿ‹u¬‹U´Fÿ9Ð~6‹\ÿÿÿBÿ¯Á ‹… ÿÿÿÙˆÙ]ØÙDˆFþ9ÐÙ]Ü~ ‹… ÿÿÿ‹Lˆ‰MàJO‰M´‰’ýÿÿ‹MÄ~‰}°9ÎŒ§òÿÿé!ûÿÿ‹}„‹ÇE´‰ÎNˆnõÿÿ»dë;ÝØ‹… ÿÿÿÙˆÙÉÚéßàžr‹\ÿÿÿBÿ¯ÁЋ• ÿÿÿÙ‚‹U´BN‰E´ˆ&õÿÿ‹U´‹\ÿÿÿBÿ¯Á‹ ÿÿÿÐÙDü‹…\ÿÿÿÙá¯ÂÐÙÙáÞÁÝáßàžt/Ø‹ ‹\ÿÿÿBÿÙƒÙɯÁ Ýáßàž‚gÿÿÿÝÙébÿÿÿzÏÝØÝ؉<$‹•dÿÿÿ¸‰D$‹pÿÿÿ‹… ÿÿÿ‰T$‹U„‰L$ ‰D$‰T$èüÿÿÿÙ]Ô‹U´ÙîÙEÔ눺‹uˆ‹½üþÿÿ‰T$,‹•Èþÿÿ‰T$(‹‰T$‹•ÿÿÿ4‡‰t$$‹…Xÿÿÿ‹½Ðþÿÿ¯Á‹tÿÿÿ‰|$ ‹½øþÿÿ4‚‰t$‹…Ôþÿÿ‹µôþÿÿ‰L$‹Uˆ‹!‰|$‰ $‰D$ ‰t$‰T$èüÿÿÿ‹}„‹éôÿÿ‰|$‹…`ÿÿÿ‹µÈþÿÿ‹½øþÿÿ¯Ð‹… ÿÿÿ‰t$‰t$ 4—‹Uˆ‰t$4ˆ‰t$‰$èüÿÿÿé¼õÿÿ‹…`ÿÿÿ‹µøþÿÿ‹Èþÿÿ¯Â‹•üþÿÿ‰L$‰L$<†‰|$ ‹}ˆ‹7‰<$²‰D$èüÿÿÿ‹M„‹é õÿÿÙîéÛýÿÿAll_napps: shift number._napps: The real part of the shift _napps: The imaginary part of the shift 1_napps: off diagonal element._napps: matrix splitting at row/column no._napps: matrix splitting with shift number._napps: Start of current block _napps: End of current block LeftRightNA_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}_napps: betak = e_{kev+1}^T*H*e_{kev}_napps: Order of the final Hessenberg matrix _napps: updated Hessenberg matrix H for next iterationsafe minimumprecision€?€¿‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@V h¨ %˜+œ(0œï8ŒEœl | #Ã…Pð  @'ñÿ  #(07@ F$NSX]  cVk‚˜  `òÿ§¯¶½ÅÌÓÛâé |òÿñù  snapps.ft0.0t1.1t2.2t3.3t4.4t5.5first.6ovfl.7smlnum.8ulp.9unfl.10.LC3.LC1.LC6.LC17snapps___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_slaset_ivout_svout_slartg_sgemv_scopy_slacpy_sscal_smout_timing_slanhs_slamch_slabad_slapy2_slarfg_slarf_saxpy_ ¢ À ÈÎø   B^ † ¡ ³ Ë × ã   1 … š ü  ˆÁ |¯¨!ä € "Ç # . $• %Ú ä !  7 j  † š ² á &ç ï õ û ' _ (©   %Û %!%™Ì   $ 5)> P V \ a*k s)‚ Œ ” š /+ñ,¶-?-Â-C ¼ Ë !(œ ´"þ.A#snaup2.o/ 1189291775 1000 1000 100644 11276 ` ELF˜4( U‰åWVSì‹}‹u èüÿÿÿËM‹U‰}È‹E‰uÄ‹}‰MÀ‹u ‰U¼‹M$‰E¸‹U(‰}´‹E0‰u°‹}4‰M¬‹u8‰U¨‹M<‰E¤‹U@‰} ‹ED‰uœ‰M˜‰U”‰E‹}H‹MP‹UT‹uL‰½pÿÿÿ‹}\‰tÿÿÿ‹Md‰UŒ‹EX‰µlÿÿÿ‹Uȉ½xÿÿÿ‹u`‰\ÿÿÿ‰Eˆ‹‰u„‹uh…À‰u€„í‹»…ÿ… ‹³$»L…ö„›‹E€º¹‰“$‹U„‰L$<‹M‰D$8‹µ\ÿÿÿ‰T$0‹E”‰L$,‹Uœ‰|$‹M¬‰t$4‹u˜‰D$(‹E¨‰t$$‹u´‰T$ ‹U¸‰L$‹MÀ‰D$‹Eĉt$‹uȉT$ ‰L$‰D$‰4$èüÿÿÿ‹Uȃ:c„.Ä[^_]Ãv‹ƒ(…À„é‹U¤‹1ö…À‰³(„¶ƒ»4Ï‹½\ÿÿÿ‹uˆ‹UŒ‰|$4‹E¬‹xÿÿÿ‰t$,‹}‹u˜‰L$0‹M”‰T$(‹Uœ‰L$‹M´‰t$‹u¸‰T$‰D$$‰|$ ‹…lÿÿÿ‰D$‹½pÿÿÿ‰t$‹uÀ‰|$ ‰L$‰4$èüÿÿÿºƒ‰“‰$èüÿÿÿ‹}Ķc…9úÿÿ‹U€‹…ÀŽ.þÿÿÇñØÿÿ‹M´‹³,‹} ‰ébýÿÿ‹UÈ1ɉ‹Çé\ùÿÿ‹ ‰ $èüÿÿÿÙƒ‹»‹uÄØ« ØGlÙ_l¶‹\ÿÿÿ‰T$‰D$4¹‹}À‰t$ ‰<$èüÿÿÿ‹MÀ‹U„‹EÈ‹1ÇBÇF‰2éùÿÿ‹‹}¬‹uÀ‰L$‹…\ÿÿÿ‰L$‰|$‰D$ ‰4$èüÿÿÿéøûÿÿ1Àƒ»4‰ƒ$xUЋMˆ‹EŒ‰T$(‹µxÿÿÿ‰D$‹E‰t$$‰L$ ‹•tÿÿÿ‰T$‹µlÿÿÿ‹U”‰t$‹pÿÿÿ³0‰D$ ‰T$‰L$‰µDÿÿÿ‰<$‰t$èüÿÿÿ‹}Ð…ÿtI‹}€Çøÿÿÿé­ûÿÿ‰|$¹,ƒ4‰L$‹‹³‰D$Q‰T$ ‰t$‰ $èüÿÿÿéMÿÿÿ³‰µPÿÿÿ‹‹0‰t$‹½xÿÿÿ¯É‰D$ ‹•Pÿÿÿ‰T$‹µpÿÿÿ‰t$‹½Dÿÿÿ‰<$èüÿÿÿ‹ƒ0‹Pÿÿÿ‰Æ‰L$¯ð‹•xÿÿÿÆ<²‰|$ ‹½Pÿÿÿ‰|$‹lÿÿÿ‰L$‹…Dÿÿÿ‰$èüÿÿÿ‰|$‹³0‹xÿÿÿ‰|$‰ò¯Ör‰T$ ‹µtÿÿÿ‰t$‹Dÿÿÿ¾‰ $èüÿÿÿ‹“@‹‹D‹E¸‰“H‹}´‰‰‰t$$‹½xÿÿÿ‰D$ ‹E´‰|$‹•tÿÿÿ‹}¸‰T$‹µlÿÿÿ‹U¼‰t$‹pÿÿÿ‰T$‹u¤‰D$ ‰L$‰|$‰4$èüÿÿÿ‹M¸‹ƒ@‹@9„ú‹µPÿÿÿ‹E´‰t$‹8‹xÿÿÿ‰t$³8ù‰T$ ‹…tÿÿÿ‹U¸ ¸‰L$‰$èüÿÿÿ‰µLÿÿÿ‹E°‹}´‰t$‰D$‹‹xÿÿÿÁÁà‰T$ ‹µlÿÿÿ‹U¸<0‰|$‹pÿÿÿ‰$ȉD$èüÿÿÿƒ»4T‹u´‹‰ÊJx,‹½tÿÿÿÙî‰ÖÙÝéßàžuz‹E´‰ñvÿ‰‹E¸ÿƒÇJyàÝØ‹“8;“H}‹u ‹»,9>|…É…= ƒ»4g‹‹L“`¸‹u”¿‰N‹M¼‰|$ ‰D$‰•hÿÿÿ‰T$‰ $èüÿÿÿ…À“bMΉ•Hÿÿÿ‰Tÿÿÿ„î‹M¼¸º‰D$ ³d‰T$‰ $‰t$èüÿÿÿ…À‹f‰Xÿÿÿ„Š¸¿‹M¼‰|$ ‰D$‹•Xÿÿÿ‰ $‰T$èüÿÿÿ…À„2¸º‹}¼‰D$ ‰T$‹Hÿÿÿ‰dÿÿÿ‰L$‰<$èüÿÿÿ…À„‹}¼‹h¸‰D$ º‰T$‰`ÿÿÿ‰L$‰<$èüÿÿÿ…À„1‹E¼¿¹‰|$»j‰L$ ‰|$‰$èüÿÿÿ…À„Ó¹‰L$‹…tÿÿÿ‰D$‹•lÿÿÿ‰T$‹pÿÿÿ‰L$ ‹…Dÿÿÿ‰D$‹•Pÿÿÿ‰T$‹Tÿÿÿ‰ $èüÿÿÿ¸º‰D$ ‹E¼‰T$‹hÿÿÿ‰$‰L$èüÿÿÿ…À„2‰t$‹u¼¸‰D$ º‰T$‰4$èüÿÿÿ…À„Ú¸º‹M¼‰D$ ‰T$‹µXÿÿÿ‰ $‰t$èüÿÿÿ…À„|¸º‹M¼‰D$ ‰T$‹µHÿÿÿ‰ $‰t$èüÿÿÿ…À„¸º‹M¼‰D$ ‰T$‹µ`ÿÿÿ‰ $‰t$èüÿÿÿ…À„Ɖ|$‹}¼¹‰L$ ¸‰D$‰<$èüÿÿÿ…À„º‰T$‹µtÿÿÿ‰t$‹lÿÿÿ‰L$‹…pÿÿÿ‰D$ ‹½Dÿÿÿ‰|$‹•Pÿÿÿ‰T$‹µTÿÿÿ‰4$èüÿÿÿ‹‹HI‰,ÿÿÿx`‹½pÿÿÿ‹µtÿÿÿ‰½<ÿÿÿ‹½lÿÿÿëÝØØ>ƒÇكƃ…<ÿÿÿÿ,ÿÿÿx+‰|$‹<ÿÿÿ‰ $èüÿÿÿÙ]ÔÙEÔÙƒPÙÉÝáßàžr¾ÝÙ뼺¾¿‰T$ ‰t$‹Xÿÿÿ‰L$‹…Tÿÿÿ‰$èüÿÿÿ‰|$ƒH‹•lÿÿÿ‰T$‹µpÿÿÿUΉt$‹tÿÿÿ‰D$‰L$ ‹½Pÿÿÿ‰$‰|$èüÿÿÿ‹³HN‰µ(ÿÿÿx`‹½pÿÿÿ‹µtÿÿÿ‰½@ÿÿÿ‹½lÿÿÿëÝØ؃Çكƃ…@ÿÿÿÿ(ÿÿÿx+‰|$‹@ÿÿÿ‰ $èüÿÿÿÙ]ÔÙEÔÙƒPÙÉÝáßàžr¾ÝÙ뼺‰T$‹µtÿÿÿ‰t$‹lÿÿÿ‹u¼‰L$‹…pÿÿÿ‰D$ ‹½Lÿÿÿ‰|$‹•Pÿÿÿ‰4$‰T$èüÿÿÿƒ»4p‹M ‹“,9}9‹‹8‹ƒH9Á} ‹}€Ç‹}´‹7…öu 9Á} ‹u€Ç‹}´‰é!óÿÿ‹ƒH‹‹8ëÒ‹E¸‹}´‹³H‹‹ƒ8‰MØ‹»l‰uà¹"u؉U܉E䃉|$‹»‰L$W‰•4ÿÿÿ‰T$ ‰t$‰D$‰<$èüÿÿÿ“¹)‰T$‰L$‹µ4ÿÿÿ‰t$ ‹…pÿÿÿ³¼‰D$‹Dÿÿÿ‰<$‰L$èüÿÿÿ‰t$º.¾5‰T$‹…4ÿÿÿ‰D$ ‹lÿÿÿ‰L$‹•Dÿÿÿ‰<$‰T$èüÿÿÿ‰t$ƒì‰D$‹4ÿÿÿ‰L$ ‹•tÿÿÿ‰T$‹µDÿÿÿ‰<$‰t$èüÿÿÿé›ùÿÿ‰“Héûøÿÿ³$¸+‰t$‹³‰D$~‰½$ÿÿÿ‰|$ ‹•pÿÿÿ»P‰T$‹Dÿÿÿ‰4$‰L$èüÿÿÿ‰|$¸0¿‰D$‹•$ÿÿÿ‰T$ ‹lÿÿÿ‰L$‹…Dÿÿÿ‰4$‰D$èüÿÿÿ‰|$“€‰T$‹$ÿÿÿ‰L$ ‹…tÿÿÿ‰D$‹½Dÿÿÿ‰4$‰|$èüÿÿÿé×ýÿÿ¸¿‰D$ ‰|$‹•`ÿÿÿ‰T$‹µTÿÿÿ‰4$èüÿÿÿé¾ûÿÿ‰t$¸º‰D$ ‰T$‹Tÿÿÿ‰ $èüÿÿÿé¥ùÿÿ‰L$¿¸‰|$ ‰D$‹½Tÿÿÿ‰<$èüÿÿÿéMùÿÿ‰T$¾¿‰t$ ‰|$‰ $èüÿÿÿéïøÿÿ» ¾0‰|$‹»‰t$G‰…0ÿÿÿ‹‹0‰D$ ‹•xÿÿÿ¯É4Š‰t$‹…Dÿÿÿ‰<$‰D$èüÿÿÿ‹ƒ0“й0‰T$‰L$‹µ0ÿÿÿ‰Â¯Ð‰t$ ‹xÿÿÿÂ4‘‰t$‹•Dÿÿÿ‰<$‰T$èüÿÿÿ¸*‹‰D$‹ƒ0‰L$‹µ0ÿÿÿ‰Â¯Ð‰t$ ‹xÿÿÿ4B±‰D$‹•Dÿÿÿ‰<$‰T$èüÿÿÿé³÷ÿÿ‰|$º¾‰T$ ‰t$‹Tÿÿÿ‰ $èüÿÿÿéúÿÿ¸º‰D$ ‰T$‹µXÿÿÿ‰t$‹Tÿÿÿ‰ $èüÿÿÿé³ùÿÿ¸º‰D$ ‰T$‹µdÿÿÿ‰t$‹Tÿÿÿ‰ $èüÿÿÿéUùÿÿ¸º‰D$ ‰T$‹µhÿÿÿ‰t$‹Tÿÿÿ‰ $èüÿÿÿé÷øÿÿ‰t$¹¸‰L$ ‰D$‹•Tÿÿÿ‰$èüÿÿÿé¥øÿÿº¹‰T$ ‰L$‹…hÿÿÿ‰D$‹•Tÿÿÿ‰$èüÿÿÿéþ÷ÿÿ‰t$º¹‰T$ ‰L$‹½Tÿÿÿ‰<$èüÿÿÿé¦÷ÿÿ¸º‰D$ ‰T$‹hÿÿÿ‰L$‹½Tÿÿÿ‰<$èüÿÿÿéB÷ÿÿ³,¸7‰t$‹³‰D$ƒV‰•8ÿÿÿ‰T$ ‰L$‰…|ÿÿÿ‰D$‰4$èüÿÿÿ‹dº+‰T$‹U´‰L$‹…8ÿÿÿ‰T$‰D$ ‹|ÿÿÿ‰4$‰L$èüÿÿÿéíÿÿ‹E¤ƒ8„e‹“4…ÒŽ1¾4»‰t$‹³‰|$~‰|$ ‹…Lÿÿÿ‰D$‹Pÿÿÿ‰4$‰L$èüÿÿÿƒ»4Žè‹E¸‹M´‹‰UØ‹º‹Ä‰EÜE؉T$“‰L$‰|$ ‰T$‰D$‰4$èüÿÿÿ‰|$ ‹U´¹)‰L$ƒÜ‰D$‹‹pÿÿÿ‰4$‹U¸‰T$‰D$èüÿÿÿ‰|$ ‹U´¹)‰L$ƒ‰D$‹‹lÿÿÿ‰4$‹U¸‰T$‰D$èüÿÿÿ‰|$ ‹U´¹.‰L$ƒ4‰D$‹:‹tÿÿÿ‰4$‹U¸¹‰D$‰T$èüÿÿÿ‹u¤‹…À…nêÿÿ‹}ȹ‰‹(Çé4êÿÿ‹E¸‰ÏÁï‹09Ñø‰³<9Ð~‰Ðƒø„…‹U¸‰‹“0‹M¸‹ƒø„’‹M´)Â9ð‰ŽLþÿÿ¾‰t$$‹xÿÿÿ‘‰D$ ‹U¸‹E´‰L$‹½tÿÿÿ‰|$‹µlÿÿÿ‹}¼‰t$‹pÿÿÿ‰D$ ‹u¤‰T$‰L$‰|$‰4$èüÿÿÿéïýÿÿ‹“0ƒú~4‰×‹M¸Áï:Ñø‰éuÿÿÿ´&ƒúŽeÿÿÿǸéUÿÿÿ‹E¸Çé9ÿÿÿ_naup2: **** Start of major iteration number ****Epsilon-Machine_naup2: B-norm of residual for compressed factorization_naup2: Compressed upper Hessenberg matrix H_naup2: The number of shifts to apply _naup2: Real part of the shifts_naup2: Imaginary part of the shifts_naup2: Ritz estimates of the shifts_naup2: Corresponding B-norm of the residualLMSRSMLRLISI_naup2: NEV, NP, NUMCNV, NCONV are_naup2: Real part of the eigenvalues of H_naup2: Imaginary part of the eigenvalues of H_naup2: Ritz estimates of the current NCV Ritz values_naup2: Sorted real part of the eigenvalues_naup2: Sorted imaginary part of the eigenvalues_naup2: Sorted ritz estimates._naup2: Real part of the eig computed by _neigh:_naup2: Imag part of the eig computed by _neigh:_naup2: Ritz eistmates computed by _neigh:_naup2: The length of the current Arnoldi factorization_naup2: Extend the Arnoldi factorization by_naup2: no. of "converged" Ritz values at this iter._naup2: NEV and NP are_naup2: "wanted" Ritz values -- real part_naup2: "wanted" Ritz values -- imag part_naup2: Ritz estimates of the "wanted" values ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@7 ä$( %x+xT0xb8ÜEìlð|ð#… ° # P#‘ñÿ  #(08 @$I(S,[0e4o8x<‚@ŠD‘H›L¤P­²·½  Ã7Ëâø `òÿ&.2 |òÿ:AHOU\dltz‚Šsnaup2.ft0.0t1.1t2.2t3.3t4.4t5.5cnorm.6getv0.7initv.8update.9ushift.10iter.11kplusp.12msglvl.13nconv.14nevbef.15nev0.16np0.17numcnv.18rnorm.19eps23.20.LC2.LC4.LC10.LC28snaup2___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_snaitr_snapps_arscnd_debug_ivout_sgetv0_slamch_powtiming_svout_smout_scopy_sdot_snrm2_sneigh_sngets_snconv_s_cmpssortc_slapy2_s_copy$ %Å Ó Ù ô b&‚ ™ ¥ ') / 7(c k q € Š • Ÿ)© À*Æ Ï û ' ; ^+p Ž ” ² º(À)Ë Û å,-  " * 5 = E O U [ n y ” ¸ È Ö(Ü â.è ü  )2/= p0v  “)™ ´*¾ ä/ó // P/[ ‚1®1 ,&Q f w (… ‹.” « Ï2ß í 3. :1` „1‘ ˜ ß ý4! + )1 H /S _ • 1› Û 1å  1! ' 0 Š 5“ ½ Ü 1& 6, o u € ’ Ÿ ¥ Ò 7Ú   7 Q 7† 7— » 7Ú ê 7; 8b 7‹ 7º 7é 77A7’8˜ è9ô 0:: q8w Ç9Ó &8, < F L  … “ › ¦ ½ Ç)è*î  '/_/i “/ž © ¸)Õ ë/#/- W/†:¯:Ø:û: )( N/T Z —/¢ ¬ á/ :9:h:—:À:ï::G:R a)k Ž*” Ä*Û î ø)*% D T !l*‚ ¤/º Ü/ò // O l á5ì snaupd.o/ 1189291775 1000 1000 100644 7024 ` ELF´4( U‰åWVSìÌ‹M ‹UèüÿÿÿËu‹E‰Mè‹M$‰Uì‹}‰uÜ‹u<‰Eä‹E0‰MÔ‹Mì‰}à‹U‰uÄ‹}4‰EЋ‰UØ‹UD…À‰}̉UÈ„Q‹ƒ\‰E´‹“X‰U°‹»‹³ ‹‹,º¸‰T$h‹UȉD$d‹E8‰T$`‹ỦD$\‰T$X‹UÄDŠü‰D$Tƒ4L²ü‰D$PDºü‰D$H‰L$L‹M°|Šü‰|$D‹»‹u´‹0‰L$O‰½dÿÿÿˆÜUÜ}Ô‰UŒ‹U¤‰}„‹}”u؉uˆMà‹u°‰MÁâ‰ù‰•lÿÿÿEÐщE€‰pÿÿÿë+‹E …À„ÇE ‹…lÿÿÿƒÆ…pÿÿÿÇÿdÿÿÿxuÙÙîÙÉÙáÙÉÚéßàžrĉ|$‹|ÿÿÿƒÆ‹UÀ‰L$‰$èüÿÿÿÙ]ä‹…|ÿÿÿ‹MÙEä‰|$‹UÀØ»‰D$ ‰L$‰$Ù]àèüÿÿÿ‹…lÿÿÿ…pÿÿÿÇÿdÿÿÿyŽv‹µ|ÿÿÿ¸“‰D$,‹M˜‹}¬‰t$(‹E¨‰L$$‹M”‰t$‹uÀ‰T$ “‰|$»‰D$‰L$‰T$ ‰t$‰t$‰<$èüÿÿÿƒ}œm‹UÀ1ɉDÿÿÿ‹2N‰µ`ÿÿÿˆ«‹}˜‹u¬‰½xÿÿÿƒÇ‹…xÿÿÿ‰½tÿÿÿ~‹u°‰…hÿÿÿë|F˜ S¤z¨Š¨#Ë“¸ P  áñÿ  #(  <AF KR7Z q‡ `òÿ–ž¦®µ¼à |òÿËÓÚsneigh.ft0.0t1.1t2.2t3.3t4.4t5.5__g77_forceload_0.6.LC2.LC7.LC6scopy_sneigh___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_slacpy_slaqrb_strevc_snrm2_sscal_sgemv_timing_slapy2_smout_svout_ Z ek¤ ¸Ý ÿI u D` s Æ Ð ì Ë ÓÙ ß!å 7L"h °Å ÷# ,$I"q {™$¤ ¶Ô$í $ .$sngets.o/ 1189291775 1000 1000 100644 3424 ` ELF4( U‰åWVSƒì\‹U‹EèüÿÿÿË}‹M‰UØ‹U ‰EÔƒ‹u ‰}ЉM̉Uȉ$èüÿÿÿ‹»º¸‹O<»‰T$ ‰MĉD$‰|$‰4$èüÿÿÿ…À…u‹UÈ¿‹M̉|$‹EЋ}Ô‰T$‹U؉L$‰D$ ‹}ð‹ ‰|$È‹‰Eðƒ‰M¼‰L$‰$èüÿÿÿ}Ü‹Mȸ‹ỦD$‹EЉL$‹MÔ‰T$‹U؉D$ ‹‹ ‰|$‹U¼‰4$ȉE܉T$èüÿÿÿ‹}ÔÙî‹uЋÙDŽüØ,ŽÝéßàžukzi‹uÌÙDŽüØŽÚéßàžuZzXAÿ‹}Ø‹M‹UÔÿƒ9‰uK‹uÌ¿‹MЉ|$‹EÈ‹UÔ‰t$‹}¼³‰L$‰D$ ‰T$‰|$‰4$èüÿÿÿët&ÝØ‹Mƒ9t¶‹‰ $èüÿÿÿÙƒ‹ƒØ«Ø@@ÙX@‹UÄ…ÒŽ»‹Mؾ‰|$‹»‹U¼‰t$w‰t$ ‰L$‰T$‰<$èüÿÿÿ‰t$ ¸ ‹UÔ‰D$‹E¼‹‰L$‰T$‰D$‰<$èüÿÿÿ‰t$ ‹Eй4‰L$“$‹MÔ‰T$‹U؉D$‹‹ ‰<$ȉEàEà‰D$èüÿÿÿ‰t$ ‹E̹4‰L$“X‹MÔ‰T$‹U؉D$‹‹ ‰<$ȉEäEä‰D$èüÿÿÿ‰t$ º8‹EȉT$‹uÔ‹Œ‰L$‹U؉D$‹‹ ‰<$uè‰t$ȉEèèüÿÿÿƒÄ\[^_]ö‰4$ƒÄº‰T$ ¹‰L$‰EÀ‰D$èüÿÿÿ…ÀuL‹Uȸ‹M̉D$‹}ЋEÔ‰T$‹U؉L$‰|$ ‹8Eì‹ ‰D$ƒω}컉}¼‰|$é[ýÿÿ‰4$¸º‰D$ ‹‰T$‰L$èüÿÿÿ…À„}‰4$¸¹‰D$ “‰L$‰T$èüÿÿÿ…À…‹Uȹ‹}̉L$‹EЋMÔ‰T$‹U؉|$‰D$ ‹:“‹Mä‰L$ø‹}À‰Eät&‰U¼‰T$‰<$é¶üÿÿ‹Mȸ‹ỦD$‹EЉL$‹MÔ‰T$‹U؉D$ ‹‹ ȉEèEè‰D$“ë´‰4$¹º‰L$ ƒÆ‰T$‰D$èüÿÿÿ…À„ƒ‰4$º¸‰T$ ‹È»‰D$‰L$èüÿÿÿ‰}¼…À}Ü…üÿÿ‹Mȸ‹ỦD$‹EЉL$‹MÔ‰T$‹U؉D$ ‹‹ ‰|$È‹MÀ‰E܃‰D$‰ $èüÿÿÿéÒûÿÿ‹Mȸ‹ỦD$‹EЉL$‹MÔ‰T$‹U؉D$ ‹‹ ȉEàEàéÿÿÿLMLRSR_ngets: KEV is_ngets: NP is_ngets: Eigenvalues of current H matrix -- real part_ngets: Eigenvalues of current H matrix -- imag part_ngets: Ritz estimates of the current KEV+NP Ritz valuesSMLISI‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@0 è p %p+p4p0 X  >tÊF@SDzHŠH#k“X à 8 °ñÿ  #(  < AH0P g}… `òÿŒ’š |òÿ¢©sngets.ft0.0t1.1t2.2t3.3t4.4t5.5__g77_forceload_0.6.LC1scopy_sngets___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_s_cmpssortc_timing_ivout_svout_ + ?EX o® · Æ n †œ ¤ª °¶ Í ßý *@ f| ¢» Þõ L W z ‡¦ ³ç F _ l‹ ‘ žæ òssaitr.o/ 1189291775 1000 1000 100644 9148 ` ELF$4( U‰åWVSìÌ‹U‹}èüÿÿÿËu‹E‰UÄ‹U$‰}¼‹},‰uÌ‹M ‰EÀ‹u‰U°‹E(‰}¬‹U<‰MÈ‹}¬‰u¸‹M ‰E”‹u0‰U‹E@‰M´‹M8‰u¨‹7‰M¤‰E ‰uœ‹M4‹ƒ‹…À‰U˜…?‹uÌ‹…É„²‹»$…ÿ…Ü‹ƒ(…À„î‹MÈ»³‰}„¶óÿÿ‹M³‹“0‰t$‹}´‰t$D‘ü‹MĉD$ ‰|$‰ $èüÿÿÿÙ]ìÙEìÙáÙúÙ›Léóÿÿ‹U°‹ƒL‹ ‰EÔ“LEЉMй3‰L$‹‰T$‰|$ ‰D$‰L$‰4$èüÿÿÿéóÿÿ‹u´ƒ‹}ĉD$‰t$‰<$èüÿÿÿë‘TN_saitr: Iterative refinement for Arnoldi residual_saitr: main diagonal of matrix H of step K+NP._saitr: sub diagonal of matrix H of step K+NP.safmin_saitr: ****** restart at step ******_saitr: re-orthonalization ; wnorm and rnorm areGeneral_saitr: generating Arnoldi vector no._saitr: B-norm of the current residual =_saitr: iterative refinement ; rnorm and rnorm1 are€?€¿P7?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ ô¸ %À+ÄX4Ä0 ¬# >ÌFLShzlŠl#“|Ð+ L¦ñÿ  #(08@ I$R([,c0j4q8x<€@ˆDH—L¡PªT´É  Þãè íóùþ   1GNV |òÿ^ `òÿelsz‰‘—Ÿssaitr.ft0.0t1.1t2.2t3.3t4.4t5.5first.6orth1.7orth2.8rstart.9step3.10step4.11ierr.12ipj.13irj.14ivj.15iter.16itry.17j.18msglvl.19rnorm1.20wnorm.21safmin.22__g77_forceload_0.23__g77_forceload_1.24.LC2.LC4.LC7.LC10.LC12.LC6.LC14smout_saxpy_ssaitr___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_sgemv_arscnd_timing_debug_ivout_sscal_svout_scopy_slamch_sgetv0_sdot_slascl_snrm2_. /x ˜ ¦ · ½ #Ö   $, K U %q y0 ª &Á Ý0ã é   ' 117 E M1u Ž '” ©2² Æ Ì #Ù $é   %  80T w &ˆ œ0¢ ± Â ß é ñ1 ' 6 < F3L #g4m z 'ƒ ¢ ° ¾ Ì (Ò Þ ç ø þ   1 2! - f #s &ƒ5‰ – ª ²1¸ ¾2Ç Ó é û3+6M v6‚ Œ1’ ˜2¡ ­ º À #Û7í ø1 97J V1\3h s { „ –  « ³ ¹ ¿ Ñ × ã8é ý  0 6 I S3Y #p4v2| ‡ (“ ™ ­  9* B H #y 7 ™ Ë 5Û ò 5ø 2   1 6 W 7` f l ¡  7à ê 1ð ö 2ÿ  " ( #M :r ‚   :° Í Ú $è   %6 #I &z „ 3Š ¡ )± 6Ä  % * ;J  ;Œ — ¡ 3« #È 4ä ø 62 17: @ g #z< ˜1ž ¤2ª »2Ç ï7ø þ  ! - 3 A1G M2V v —:¬ ½ è7    )24 ; Œ<£ «1± ·2À Ú #à :   + @ )X6f #y<+,ssapps.o/ 1189291776 1000 1000 100644 5560 ` ELF¬4( U‰åWVSì,‹}‹uèüÿÿÿËU‹E‰}È‹} ‰uÀ‹u,‰U¼‹U4‰…\ÿÿÿ‹E‰½üþÿÿ‹M ‰µtÿÿÿ‹}$‰•`ÿÿÿ‹u0‰E¸‹‰MÄ‹M(‰E°‹ƒ‰M´‹…À‰M¬‹‰U¨…“ÇEœ‹‰ $èüÿÿÿ‹“‹}À‹MĉU”‹B‹‹‰E˜‹¿‰t$‹µtÿÿÿЉEè“Eè‰|$»‰t$‰Lÿÿÿ‰L$‰•Hÿÿÿ‰T$ ‰…Xÿÿÿ‰D$‰D$‰½Dÿÿÿ‰<$èüÿÿÿ‹uÀ‹…À„ìÇEàH‰Eˆ ƒ‹M”»‰…@ÿÿÿ‹E”U䉽<ÿÿÿƒÁ»(‰ÿÿÿ‹uèMà‰•8ÿÿÿ“L‰…4ÿÿÿE܉½0ÿÿÿ}؉,ÿÿÿMÔ‰•(ÿÿÿUЉ…$ÿÿÿẺ½ ÿÿÿ»‰ÿÿÿ‰•ÿÿÿ‰…ÿÿÿ‰½pÿÿÿ‹Uœ‰U ‹E ‰÷‹M )ljMä‰ùIxrÙƒ‹½<ÿÿÿ‹•ÿÿÿ‹…4ÿÿÿ‰}Œ‹½0ÿÿÿ‰Uˆ‹•(ÿÿÿ‰E„‰}€‰•|ÿÿÿ‹Uä‹E¬‹½üþÿÿÐÙD‡üÙ‡ÙÉÙáÙÉÙáÞÁÙ—ÙÉØÊÚéßàžƒzI‰}äyÆÝ؉u¤‹M¤9M Œ(‹M¤Ùî‹u¤‹½üþÿÿA‰M ÙD·üÙÉÝéßàž‡ÂÝØ‹uè9u¤Œ<ÿÿÿ‹Uœ‰÷)׉ùIx)‹EœÙî‰Eäë ÿEœBIx‰Uä‹U䋽üþÿÿÙ—ÝéßàžvãÝØÿEàÿM‰õþÿÿë‹u苉@ÿÿÿ‹Eœ‹Uœ)ƉUäNˆ‹ƒ»M䉽lÿÿÿP‰Tÿÿÿ»L‰• ÿÿÿ‰…hÿÿÿ‰½dÿÿÿ‹Uä‹}¬‹üþÿÿ×ÙD¹üÙ¹ÙÉÙáÙÉÙáÞÁÙ‘ÙÉØ‹Úéßàž‚¢‹E˜…ÀŽ‡‹•lÿÿÿ¹#‹½Tÿÿÿ‰L$‹… ÿÿÿ‹@ÿÿÿ‰T$‹•hÿÿÿ‰|$‰L$‰$‰D$ èüÿÿÿ¸.‹½dÿÿÿ‹ ÿÿÿ‰D$‹•üþÿÿ‹Eä‰|$‰L$ <‚‹@ÿÿÿ‰|$‹•hÿÿÿ‰L$‰$èüÿÿÿ‹U䋽üþÿÿÇ—‹UäBN‰Eä‰ÿÿÿ‹UÄÙüþÿÿ‹ ÙŽÚéßàž‡ÇEä‰ÎNˆê»zE쉽ÿÿÿ‰…Pÿÿÿë‹UÄ‹ ‹•Hÿÿÿ¿‹…`ÿÿÿ‰|$,‹½@ÿÿÿ‰T$ ‹Uä‰|$(‰|$‹}¨)щD$$¯ù‹tÿÿÿ¹‹}¸‰D$‹Lÿÿÿ‹…\ÿÿÿ‰|$‹}è‰D$‹EÈ)׉L$ ‹•PÿÿÿG‰}ì‹ÿÿÿ‰D$‰T$‰ $èüÿÿÿ‹}ä‹Eè‹U°‹@ÿÿÿ)ø¯Â‰L$‹½\ÿÿÿ‰L$‹Mȇ‰T$ ‹…`ÿÿÿ‰ $‰D$èüÿÿÿÿEäN‰-ÿÿÿ‹U¸¹‹µ\ÿÿÿ‰L$‹}À‹M°‰T$‰t$‰T$‹‹}ȯȋEĉ|$Ž‹Dÿÿÿ‰T$ ‰D$‰ $èüÿÿÿ‹UÄÙüþÿÿ‹ ÙŽÚéßàž‡Qÿ‹M¨‹E´‹µ@ÿÿÿ¯Ñ‹½tÿÿÿ‰D$‹Eè‰t$ 4—‹UÈL†ü‰L$‰$èüÿÿÿ‹uÄÙüþÿÿ‹Ù—Úéßàž‡ôƒ}˜Ì³‰4$èüÿÿÿÙƒ‹“Ø«ØB(ÙZ(Ä,[^_]ù“{‰L$‰$èüÿÿÿÙ›1À‰ƒéCúÿÿÙàÙ\·ü‹M¨‰÷O‹…@ÿÿÿ‹•tÿÿÿ¯ù‹µXÿÿÿ‰D$ ‰4$º‹½pÿÿÿ‰D$‰|$èüÿÿÿéýûÿÿ‹E ‹u¬‹Uà‹M¼Æ‹} ‹…üþÿÿÙD‘ü‹$ÿÿÿ‹¸Øl°ü‹½ÿÿÿ‰L$‹… ÿÿÿ‰UЋÿÿÿ‹•ÿÿÿÙ]̉|$‰T$‰D$ ‰ $èüÿÿÿÙEÔ‹…üþÿÿ‹} ÙEØ‹UàÙ¸ÙD°üÙ°ÙÂÙÂÙÂÙÊØÎÙÍØÏÙÉØÏÙÊØÎÙËØÏÙÊØÅÙËØÁÙÌØÎÙÌØÎÙËØÏÙÊÞåÞãÞÁÙÃØÊÙÊØÍÙÉÙ\°üÙÄØËÙËØÌÙËÞâÞÂٰٸ‰øЋUè9Ð~‰ÐH‰…øþÿÿxW‹M ‹E¨‹}¨Qÿ¯Ð‹µtÿÿÿ¯ù –¾´&ÙÙÙÁÙÁÙÉØÍÙÉØÌÙÊØÍÙËØÌÙÉÞÂÞêÙÉÙƒÀÙƒÁÿøþÿÿyÎÝØÝØ‹} ‹u¤G‰}ä)þN‰µxÿÿÿ´&ˆuúÿÿ‹Uä‹üþÿÿ‹t‘üÙ‘‰uÌÙÀØMØÙÉØMÔÙÉÙ]ÐÙ‘‹…$ÿÿÿ‹½ ÿÿÿ‹µÿÿÿ‹ÿÿÿ‰D$‹•ÿÿÿ‰|$ ‰t$‰L$‰$èüÿÿÿÙEÜÙîÝéßàžv Ùà€u×€€uÛ€ÙUÜÙEÔ‹M䋵üþÿÿÙEØÙÊ‹}àÙ\Žü‹E¬‹•üþÿÿÈÙD‚üيقÙÂÙÂÙÂÙÉØÏÙÌØÎÙÊØÎÙÉØÏÙÍØÏÙÉØÄÙÍØÂÙËØÎÙËØÏÙÍØÎÙÊÞáÙÊÞãÞÃÙÄØÉÙÉØÌÙËÙ\‚üÙÃØÊÙÊØÍÙÊÞáÙÊÞÁÙÉÙ‚‰ÈøÙŠ‹Uè9Ð~‰Ð‰ÆNxV‹}¨Aÿ‹U¨¯Ï‹½tÿÿÿ¯Â‰ÿÿÿ‹•ÿÿÿ ‡—fÙÙÙÁÙÁÙÉØÌÙÉØÍÙÊØÌÙËØÍÙÉÞÂÞêÙÉÙƒÀÙƒÁNyÓÝØÝØÿEäÿxÿÿÿéþÿÿÝØ‹u˜…öŽ¥‹½8ÿÿÿ¸#‹UŒ‰D$‹Mˆ‹u„‰|$‹½@ÿÿÿ‰T$‰L$ ‰|$‰4$èüÿÿÿ‰|$‹U€¸$‰D$‹Mˆ‹µ,ÿÿÿ‰T$‹}„‰L$ ‰t$‰<$èüÿÿÿ‰<$‹Mˆ¸.‰D$‹•|ÿÿÿ‹Eä‰L$ ‹µüþÿÿ‹@ÿÿÿ‰T$†‰T$‰L$èüÿÿÿ‹U䋵üþÿÿÇ–‰U¤é)øÿÿº‹}È‹µ`ÿÿÿ‰T$,‹•@ÿÿÿ‰T$(‹‹½Hÿÿÿ‰T$†‹u¨‰D$$‹•tÿÿÿ‰|$ ¯ñ‹M¸‹½\ÿÿÿ‰L$²‹•Lÿÿÿ‰D$‹µXÿÿÿ‹z‰|$‹Eȉ $‰T$ ‰t$‰D$èüÿÿÿ‹}Ä‹éuùÿÿ³Œ‹Uĸ-‰t$‹³‹}¨‰D$N‰ÿÿÿ‰L$ ‹‰4$‹tÿÿÿH¯Ç‹Eè|‚ü‰|$‹½@ÿÿÿ‰|$èüÿÿÿ‹…ÿÿÿº,‹¼‰T$‹UĉL$‹üþÿÿ‰D$ ‹‰|$‰4$‰T$èüÿÿÿ‰4$‹½ÿÿÿ¹5‰L$‹U¬ƒè‰D$‹üþÿÿ‰|$ ‹}Ä‘‰D$‰|$èüÿÿÿ‹ƒúŽZúÿÿ‰4$¸4‹½ÿÿÿ‰D$‹…üþÿÿ‹ ‰L$ƒÀ‰|$ Jÿ‰D$}ì‰Mì‰|$èüÿÿÿéúÿÿ‹}°‹@ÿÿÿ‹E´¯ú‹µ\ÿÿÿ‰L$‰L$ ‹üþÿÿ‰D$¾<‘‰D$‹Uȉ|$‰$èüÿÿÿéÇùÿÿ‹E°‹µ@ÿÿÿ‹½`ÿÿÿ¯Á‹\ÿÿÿ‰t$‰t$‰T$ ‹UÈ‹ ‰$‰D$èüÿÿÿ‹uÄ‹é.ùÿÿAll_sapps: deflation at row/column no._sapps: occured before shift number._sapps: the corresponding off diagonal elementNEpsilon-Machine_sapps: sigmak of the updated residual vector_sapps: betak of the updated residual vector_sapps: updated main diagonal of H for next iteration_sapps: updated sub diagonal of H for next iteration€?€¿‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@X  øÀ %˜ +œ 0œ T8ð El|#'…´`  ãñÿ  #(09>CH  MX Ul‚Š `òÿ‘™ §®µ½Ä |òÿÌÔÜssapps.ft0.0t1.1t2.2t3.3t4.4t5.5first.6epsmch.7.LC1.LC2.LC5.LC8ssapps___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_slaset_ivout_svout_sgemv_scopy_slacpy_sscal_timing_slamch_slartg_saxpy_ i ‹ “™­ Ì Ù 1 : U m ¦ Ü Ô òø  L ¡æ7 Óg »!æ îô ú"  (#. 6 z!Ý$=$ž Î  ‡ ¢ ² Ä   ? Z { ¤ Å  %J ssaup2.o/ 1189291776 1000 1000 100644 9748 ` ELFX4( U‰åWVSì‹E‹M èüÿÿÿË}‹U‰EÀ‹u‰M¼‹E‰}¸‹M ‰U´‹}$‰u°‹U(‰E¬‹u0‰M¨‹E4‰}¤‹M8‰U ‹}<‰uœ‹U@‰E˜‹uD‰M”‰}‰UŒ‰uˆ‹ML‹UT‹EH‹uX‰dÿÿÿ‹M`‰U€‹Uˆ‰…`ÿÿÿ‹E\‰µhÿÿÿ‹}P‰Tÿÿÿ‹2‰…|ÿÿÿ‹EÀ‰µtÿÿÿ‰}„‹‹}d…ɉ½xÿÿÿ„Å‹“…Ò…‹“$»D…Ò„£‹…xÿÿÿº¾‰“$‹•|ÿÿÿ‰t$<‹uˆ‰D$8‹Tÿÿÿ‰T$0‹EŒ‰t$,‹U”‰|$‹u¤‰L$4‹M‰D$(‹E ‰L$$‹M¬‰T$ ‹U°‰t$‹u¸‰D$‹E¼‰L$‹MÀ‰T$ ‰t$‰D$‰ $èüÿÿÿ‹UÀƒ:c„Ä[^_]Ãt&‹ƒ(…À„‹Uœ‹1ö…À‰³(„¦ƒ»4ï‹Tÿÿÿ‹E€‹U„‰L$,‹}¤‹uˆ‰D$(‹MŒ‹E‰T$$‹U”‰t$‹u¬‰L$‹M°‰D$‹E¸‰T$‰|$ ‹½`ÿÿÿ‰t$‰L$‰|$ »‰$èüÿÿÿ‰<$º‰“èüÿÿÿ‹u¼¶c…þÿÿÙƒDÙîÙÉÚéßàž…ÌŠÆ‹xÿÿÿÇ÷ÿÿÿé'»‰<$¿`èüÿÿÿ‹³¹ƒ1‹V¾UUå?‰L$‰“4‰$èüÿÿÿÙ]ÔÙEÔ‰|$‰t$ 1öÝ$èüÿÿÿ‰³8‹U°1ö‰³‹M¬‹µxÿÿÿÙ›H‹:‹1Ò1ɉ“,‹‰»<ljƒ@¸‰»01ÿ…Ò‰ƒ‰‹$‰»(t9Ǹ‰ƒ énüÿÿv‹‹…É„‹}¼¶éÔýÿÿ´&1ɉ‹ é>üÿÿv‹µxÿÿÿ‹…ÀŽÕÇñØÿÿ‹U¬‹‹,‹}˜‰‰‹}À“Çc‰$èüÿÿÿÙƒ‹ƒØ«ÙXÄ[^_]ó@º0ƒ‰t$‹³‰T$N‰,ÿÿÿ‰L$ ‰|$‰D$‰4$èüÿÿÿº,‹p‰L$‹MŒ‰T$‹…,ÿÿÿ‰D$ ‹•tÿÿÿ‰4$‘‰D$‹E°‰D$èüÿÿÿº*‹œ‰T$‹UŒ‰L$‹…,ÿÿÿ‹M°ƒÂ‰T$ỦD$ ‹H‰ẺT$‰4$èüÿÿÿ‹ƒ4éËüÿÿ³È‹E¬¿&‰t$‹³“‰|$~‰T$‰|$ ‰D$‰4$èüÿÿÿ‰|$ ¹ƒî‰L$‹M¬‰D$‹•hÿÿÿ‰L$‰4$‰T$èüÿÿÿ‹Eœƒ8…œûÿÿ‰|$ ¹$ƒ‰L$‹M¬‰D$‹•dÿÿÿ‰L$‰4$‰T$èüÿÿÿégûÿÿ‹‹E¬‰L$‹•`ÿÿÿ‰L$‰T$ ‹½hÿÿÿ‰$‰|$èüÿÿÿé(ûÿÿ‹…xÿÿÿ¹‹µ|ÿÿÿ‰L$<‹Mˆ‰D$8‹•Tÿÿÿ‰t$0‹EŒ‰L$,‹M¤‰|$‹u”‰T$4‹U‰D$(‹E ‰T$$“<‰L$‹M¸‰D$‹E¼‰T$‹UÀ‰t$ ³‰t$ ‰L$‰D$‰$èüÿÿÿ‹uÀƒ>c…gúÿÿ‹•xÿÿÿ‹…ÀŽ{þÿÿÇñØÿÿ‹M¬‹³,‹}˜‰‰7érýÿÿ‹uÀ1ÿ‰»Çéùÿÿ³ ‰4$èüÿÿÿÙƒ‹ƒ‹U¼Ø« Ø@lÙXl¶‹u¬‹‰ÊJx,‹½dÿÿÿÙî‰ÖÙÝéßàžuz‹E¬‰ñvÿ‰‹E°ÿƒÇJyàÝØ‹“8;“<}‹u˜‹»,9>|…É…=‹M´“`¸‰D$¿‰|$ ‰•Lÿÿÿ‰T$‰ $èüÿÿÿ…À…™»b¸¹‰|$}ƉD$ ‰L$‰<$èüÿÿÿº‰T$‹µdÿÿÿ‰t$‹…`ÿÿÿ‰D$ ‹@ÿÿÿ‰L$‹•<ÿÿÿ‰T$‰½Pÿÿÿ‰<$èüÿÿÿ‹“<ƒd‹M°‰…Hÿÿÿ‰ÖÁî<2Ñÿ‰Ö)þƒ9Žñ‹…<ÿÿÿ‹M¬‰D$‹ƒ0‹ ‰Â)ú)ȉ$ÿÿÿ•…9Â}‰Â‹`ÿÿÿÁæD ü‰D$ ‹…<ÿÿÿ‰T$‰D$‹…$ÿÿÿ9ø~‰ø‰EÐMЉ $èüÿÿÿ‹…<ÿÿÿ‹M¬‰D$‹ƒ0‹ ‰Â)ú)ȉ$ÿÿÿ•…9Â}‰Â‹dÿÿÿD ü‰D$ ‹…<ÿÿÿ‰T$‰D$‹…$ÿÿÿ9ø~‰ø‰EÌ}̳d‰<$èüÿÿÿ‹“<‰µHÿÿÿ‰ÑIx0ÙƒH‹½dÿÿÿ‹•`ÿÿÿÙÙáÝáßàžsÝØÙÀØ?ƒÂÙƒÇIyäÝغ¿‰T$ ‰|$‹Hÿÿÿ‰L$‹µPÿÿÿ‰4$èüÿÿÿ¸‹<‰D$‹•`ÿÿÿ‰T$‹½dÿÿÿ‰L$‰|$ ‹µ<ÿÿÿ‰t$uƉ4$èüÿÿÿ‹‹<Ix0ÙƒH‹½dÿÿÿ‹•`ÿÿÿÙÙáÝáßàžsÝØÙÀ؃ÂÙƒÇIyäÝظº‹M´‰D$ ‰T$‹½Lÿÿÿ‰ $‰|$èüÿÿÿ…À…׺¿‰T$ ‰|$‹Hÿÿÿ‰4$¾‰L$èüÿÿÿ‰t$‹…dÿÿÿuƉD$‹•`ÿÿÿ‰T$ ‹½Dÿÿÿ‰|$‹<ÿÿÿ‰4$‰L$èüÿÿÿƒ»4‹‹D‹uŒ‰~‹E˜‹“,9}J‹M°‹ƒ89~ ‹½xÿÿÿÇ‹M¬‹1…öu;ƒ<} ‹½xÿÿÿÇ‹u¬‹M˜‹}°‰‰‰éSöÿÿ‹ƒ8ëǸ‰D$‹•dÿÿÿ‹E´‰T$‹½`ÿÿÿ‰|$ ‹Dÿÿÿ‰L$‹µ<ÿÿÿ‰$‰t$éHÿÿÿ‹U´¸¹‰D$ ³f»h‰$‰L$‰t$èüÿÿÿ…ÀUƉ•Pÿÿÿ„º‰|$‹}´¸‰D$ º‰T$‰<$èüÿÿÿ…À„h‹U´ƒd¹‰L$ ¾»b‰t$‰Æ‰…Hÿÿÿ‰D$‰$èüÿÿÿ…À„‰|$‹}´¸‰D$ º‰T$‰<$èüÿÿÿ…À„°º‰T$‹½dÿÿÿ‰|$‹`ÿÿÿ‰L$ ‹µ@ÿÿÿ‰t$‹…<ÿÿÿ‰D$‹•Pÿÿÿ‰$èüÿÿÿ‹“<éÓüÿÿ‹>³j‹‹8‹U¬‰}Ø¿‹‰Mà‹‹U؉E܃‰|$¿‰t$q‰\ÿÿÿ‰t$ ‰T$‰ $‰D$èüÿÿÿ‰t$ “„‰T$‰|$‹…`ÿÿÿ‰D$‹@ÿÿÿ‰L$‹½\ÿÿÿ‰<$èüÿÿÿ‰t$ º5ƒ ‰T$‰D$‹dÿÿÿ‰L$‹½@ÿÿÿ‰|$‹µ\ÿÿÿ‰4$èüÿÿÿéöùÿÿ¾»Õ‰t$‹³‰|$¿N‰µXÿÿÿ‰0ÿÿÿ‰L$ ‹…`ÿÿÿ‰D$‹•@ÿÿÿ‰4$‰T$èüÿÿÿ‰|$‹ð‰L$‹µ0ÿÿÿ‰t$ ‹…dÿÿÿ‰D$‹•@ÿÿÿ‰T$‹½Xÿÿÿ‰<$èüÿÿÿéöüÿÿ‹E°‹09Ö~ ‹}œƒ?„L‹‹4…É~I³¿4‰t$‹³‰|$~‰|$ ‹…Dÿÿÿ‰D$‹•<ÿÿÿ‰4$‰T$èüÿÿÿƒ»4D‹uœ‹…À…ðÿÿ‹}À¹‰‹(ÇéÜïÿÿ¸7‹u°‹D‰D$‹ƒ‰L$P‰•8ÿÿÿ‰…pÿÿÿ‰t$³‰T$ ‰t$‰$èüÿÿÿ¹+ƒ|‰L$‹M¬‰D$‹•8ÿÿÿ‰L$‰t$‰T$ ‹µpÿÿÿ‰4$èüÿÿÿé©ðÿÿ‰t$¿¹‰|$ ‰L$‹µPÿÿÿ‰4$èüÿÿÿé'ýÿÿ‰|$¹¸‰L$ ‰D$‹•Pÿÿÿ‰$èüÿÿÿéÕüÿÿ‰t$¿¹‰|$ ‰L$‹µPÿÿÿ‰4$èüÿÿÿéoüÿÿ‰|$¹¸‰L$ ‰D$‰$èüÿÿÿé#üÿÿ‹U°‹M¬‹º‰EØ‹‹§‰EÜE؉T$“‰L$‰|$ ‰T$‰D$‰4$èüÿÿÿ‰|$ ‹U¬ƒ½‰D$¹‰L$‹`ÿÿÿ‹‰4$‹M°‰T$‰L$èüÿÿÿ‰|$ ‹M¬“܉T$¸.‰D$‹‹½dÿÿÿ‰4$‹M°‡‰T$‰L$èüÿÿÿéþÿÿ‰ÈÁèÑø9Ð~‰Ðƒøtm‹U°‰‹“0‹M°‹ƒøtt‹M¬)Â9ð‰Žxýÿÿ¿‰|$‹µhÿÿÿ‹}°‰t$‹…dÿÿÿ‹uœ‰D$‹•`ÿÿÿ‰L$ ‹M´‰T$‰|$‰L$‰4$èüÿÿÿé/ýÿÿ‹“0ƒú~&‰×‹M°Áï:Ñø‰댃ú~‡Ç¸éwÿÿÿ‹E°Çé_ÿÿÿ_saup2: **** Start of major iteration number ****Epsilon-Machine_saup2: B-norm of residual for NEV factorization_saup2: main diagonal of compressed H matrix_saup2: subdiagonal of compressed H matrix_saup2: The number of shifts to apply _saup2: shifts selected_saup2: corresponding Ritz estimates_saup2: Current B-norm of residual for factorizationBESALALMSM_saup2: NEV, NP, NCONV are_saup2: The eigenvalues of H_saup2: Ritz estimates of the current NCV Ritz values_saup2: Sorted Ritz values._saup2: Sorted ritz estimates._saup2: no. of "converged" Ritz values at this iter._saup2: The length of the current Lanczos factorization_saup2: Extend the Lanczos factorization by_saup2: NEV and NP are_saup2: "wanted" Ritz values._saup2: Ritz estimates of the "wanted" values ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@; ô %|+|L4|0 & >€ FŒSœz Š #Ó°°# `‘ñÿ  #(08 @$I(S,[0e4o8x<€@‡DH™  ®³¸¾  ÄË;Ó ê `òÿ&.6: |òÿBIPV]emu{‚Šssaup2.ft0.0t1.1t2.2t3.3t4.4t5.5cnorm.6getv0.7initv.8update.9ushift.10iter.11kplusp.12msglvl.13nconv.14nev0.15np0.16rnorm.17eps23.18__g77_forceload_0.19.LC2.LC4.LC10.LC22sscal_ssaup2___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_ssaitr_ssapps_arscnd_debug_ivout_sgetv0_slamch_powtiming_svout_scopy_sdot_snrm2_sseigt_ssgets_ssconv_s_cmps_copyssortr_sswap_% &Í Û á ÿ p'’ © µ   (. 3)a g m | † ‘ ›*¥ ¼+Â í  0 S,e ’ Ÿ)¥*°  Ê-â.è ó      + 5 ; A T b „ « » É)Ï Õ/Û ï ú *%00 a0l  0¦ ± Ã*É ä+ó 0/ P0[ ‚1Ö õ  '4 K \ d)j p/y  ´2Ä Ò å3í/ó 1H l1y € ¯ Í4ô þ*  0& 2 _ 1e ’ 1˜ ¦ ì 5, 15 o 6u ¸ ¾ É Þ  7 1 8p 9v | ¯  : y  :‡ ˜ ì 8÷ ( 9. 7 ˆ 7¹ 8ð 9ö ý   = e º À Ð77 ' ?7h7¯9µ Â È Þ*ê + H0W 0‘ ›*Ó0Ý  0- 7 F*m+s • ® ¸*Õ å+ð +D8m8–8¹8Ö æ !þ+  60C n0– ó5þ #ssaupd.o/ 1189291776 1000 1000 100644 6860 ` ELF 4( U‰åWVS켋M ‹UèüÿÿÿËu‹E‰Mè‹M$‰Uì‹}‰uÜ‹u<‰Eä‹E0‰MÔ‹Mì‰}à‹U‰uÄ‹}4‰EЋ‰UØ‹UD…À‰}̉UÈ„0‹“X‰U°‹³‰u¬‹»$‹‹0º¾‹EȉT$d‹U8‰t$`‹ủD$\‰T$X‰t$T‹uÄDŽü‰D$PT¾ü‹8‰T$H‰L$L‹}¬D¾ü‰D$D‹ƒ ‹M°»4‰|$ L !W %a-‚0‘ !¯0¾ !È æ1õ !ÿ 1# +,1 : C Q W _2d3q2‡ %4§4½4Ø4ø44)4D4d44•4°4Ð4ë44474<3N ` r ¢ ­ Î Ù ç õ     R !b. !‘.¢ !À.Ö !ï. / !?.R g š !¦5Ù   ssconv.o/ 1189291776 1000 1000 100644 1532 ` ELFÌ4( U‰åWVSƒì‹uèüÿÿÿÓ‹}‰$èüÿÿÿ‹¸‰ $‰D$èüÿÿÿÙ]ðº`¸UUå?ÙEð‰T$‰D$ Ý$èüÿÿÿÙ]ð‹ÙEðÇIx;‹u‹UÙ‹u t&ÙÙáÝâßàžsÝØÙÁÙÁÞÉÙÙÉÚéßàžrÿƒÆƒÂIy×ÝØÝØ‹‰ $èüÿÿÿÙƒ‹»Ø«ØG,Ù_,ƒÄ[^_]ÃEpsilon-Machine‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@Û œ` %+08+_/o/#Rx¬p  €ñÿ  #( `òÿ/ |òÿ7Û?Vlt|ssconv.ft0.0t1.1t2.2t3.3t4.4t5.5debug_timing_ssconv___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_slamch_pow   $* ;[¯ ·½ ÃÉ sseigt.o/ 1189291776 1000 1000 100644 2136 ` ELFx4( U‰åWVSƒìL‹}‹M èüÿÿÿËE ‹u‰}è‹}‰MÌ‹U‰Eì‹E$‰uä‹7‰Uà“‰u؉$‰EÜèüÿÿÿ‹³Mð‹Uè‹Fz‰MÈ…À‰EÔ~J‰4$‹¸!‰L$‹M؉D$F‰EЉD$ Š‹Uì‰D$‰T$èüÿÿÿ‹Mì‹Mð‰Mȃúê‹E䳋U؉t$‹Mè‰D$ ‰t$‘‹Uì‰D$‰$èüÿÿÿ‰t$‹EÌ‹Mì‰t$‹uȉ|$‰D$ ‹‰4$J‰Uðèüÿÿÿ‹}Ü‹Eì‹uà‰|$‹‹}̉t$ ‹Eä —‰L$‹Uì‰|$‰D$‰$èüÿÿÿ‹MÜ‹1…öuRƒ}Ô‹‹uì‹Jx‹M‹EàÙfÙÙáØÉÙƒÀJyòÝ؃‰$èüÿÿÿÙƒ‹“Ø«ØB ÙZ ƒÄL[^_]ÉL$¿ ƒ$‰|$‹}ЉD$Bÿ‰|$ ‹}è‰Eð‰4$ƒÇ‰|$èüÿÿÿéÛþÿÿ¿0‹MàƒD‰|$‹»‹uì‰D$W‰T$ ‰L$‰t$‰<$èüÿÿÿé:ÿÿÿ_seigt: main diagonal of matrix H_seigt: sub diagonal of matrix H_seigt: last row of the eigenvector matrix for H‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ °¨ %T+T0Tt8ÈEÌlÐ|Ð#ó…€    ñÿ  #( -5Lbj `òÿqx‡ |òÿsseigt.ft0.0t1.1t2.2t3.3t4.4t5.5.LC2sseigt___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_svout_scopy_sstqrb_timing_ < JPo œ¹ Ý7r z€ †Œ © Ðã í ssgets.o/ 1189291776 1000 1000 100644 2560 ` ELFŒ4( U‰åWVSƒì<‹}‹MèüÿÿÿËU‹E‰}介u ‰M܉U؉<$‰Eàèüÿÿÿ‹ƒ¹º‹x ƒ‰L$ ‰T$‰D$‰4$èüÿÿÿ…À…Q‹uع‹E܉L$‹Uà‹Mä‰t$‰D$ ‹1‹‹Uð‰T$ð‰Eðƒ‰MÔ‰L$‰$èüÿÿÿ‹u䋉ÊÁê4ÑþIŽ5‹UÔ‹Eà‰T$‹9ò‰ÐŒ<‹MÜ9ò‰D$ ‹EÔ‰L$‰D$‰Ð~‰ð‰EìEì‰$èüÿÿÿ‹UÔ‹Mà‰T$‹9ò‰Ð}‰ð‹MØ9ò‰D$ ‹EÔ‰L$‰D$‰Ð~‰ð‰Eèuè‰4$èüÿÿÿ‹uƒ>…µt&‹Uà‹…ÀŽ¤‰T$‹uع‰L$‹UÔ‹‰ $‹E܉t$ ‰T$‰D$èüÿÿÿ‹uÔ‹E ‹U܉t$‹Mà‰D$ ‰t$‰T$‰ $èüÿÿÿëN‹Mغ‹E܉T$‹Uà‰L$‹Mä‰D$ ‹‹‰4$Mè‰L$Г‰Eè‰UÔ‰T$èüÿÿÿ‹uƒ>„Oÿÿÿ³‰4$èüÿÿÿÙƒ…ÿ‹“Ø«ØB$ÙZ$ŽÛ»‹U侉|$‹»‹MÔ‰t$w‰t$ ‰T$‰L$‰<$èüÿÿÿ‰t$ ¸ ‹Mà‰D$‹EÔ“‰T$‰L$‰D$‰<$èüÿÿÿ‰t$ ‹Eܺ'‰T$‹$‹Uà‰L$‹Mä‰D$‹‹‰<$ЉEèEè‰D$èüÿÿÿ‰t$ ¹!‹u؉L$‹Eà“L‰T$‹Mä‰t$‹0‹‰<$Eì‰D$Ö‰uìèüÿÿÿƒÄ<[^_]Éðé½ýÿÿBELASM_sgets: KEV is_sgets: NP is_sgets: Eigenvalues of current H matrix_sgets: Associated Ritz estimates‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@)  ø %l+l0lm8ÜEàlä|ä#…”Ð  d£ñÿ  #( -)5Lbj `òÿqw† |òÿ•œssgets.ft0.0t1.1t2.2t3.3t4.4t5.5.LC1ssgets___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_s_cmpssortr_sswap_scopy_timing_ivout_svout_ % 9?R f“ § ¶ L‚ ™½ò  ! )/ A SqŠ ž´ Úó sneupd.o/ 1189291776 1000 1000 100644 13228 ` ELFˆ(4( U‰åWVSìl‹E‹U èüÿÿÿË}‹u‰…|ÿÿÿ‹M‰•xÿÿÿ‹E‰½tÿÿÿ‹U ‰µpÿÿÿ‹}$‰lÿÿÿ‹u(‰…hÿÿÿ‹M,‰•dÿÿÿ‹E0‰½`ÿÿÿ‹U4‰µ\ÿÿÿ‹}8‰Üþÿÿ‹u<‰…Xÿÿÿ‹M@‰•Tÿÿÿ‰½Pÿÿÿ‰µLÿÿÿ‰Hÿÿÿ‹M`‹EH‹UL‹}P‰øþÿÿ‹u\‰…Dÿÿÿ‹Mh‰•@ÿÿÿ‹ƒ‰½<ÿÿÿ‹UT‰µØþÿÿ‹}X‰8ÿÿÿ‹p@‹B‰µÿÿÿ‹rº‰E¬ƒÇ‰$‰T$èüÿÿÿÙ]Ô¹`ºUUå?ÙEÔ‰L$‰T$ Ý$èüÿÿÿÙ<þÿÿ‹E¬…ÀŽ ‹•Tÿÿÿ‹ …ÉŽ‹•Lÿÿÿ‹…ÀŽ"@‰…äýÿÿ‹…Dÿÿÿ‹;•äýÿÿ~9ÊŽ;ÇE¤ýÿÿÿFÿƒø†nƒþ„ºƒþ„Ý ÇE¤öÿÿÿN„|´&¼'‹E¤…Àt‹½8ÿÿÿ‰Äl[^_]ö‹G‹•Dÿÿÿ‹O‰… ÿÿÿ‹w‹‰0ÿÿÿ‹O‰Â‰µÿÿÿ¯Ð‰4ÿÿÿÁ‰(ÿÿÿÁ‹µ(ÿÿÿ‰$ÿÿÿÁ‰,ÿÿÿÁ‰ÿÿÿщÿÿÿ‹$ÿÿÿ‰E ‰E¨‰O$‹ÿÿÿ‰w ‹µ,ÿÿÿ‰O,‹O4‰w(‹µÿÿÿʉ•ÿÿÿÂЉw0‹øþÿÿ‰•ÿÿÿ‹•0ÿÿÿ‰…ÿÿÿ¸‹t‘‰uˆ‰D‘ƒ½ÿÿÿ¬‹|ÿÿÿ‹…À„l‹½Dÿÿÿ1ö‰µüþÿÿ‹¿‰•äýÿÿ‰ÖNxE‹•4ÿÿÿ‹…øþÿÿ‹tÿÿÿTü‰•àýÿÿt&W‹•àýÿÿGÛ$ƒÄÙƒÂǃÁN‰•àýÿÿyÛ‹•Lÿÿÿ¹‹½äýÿÿ‹2ÇE´)÷‰}¸‰L$$‹øþÿÿ¹‰L$‰D$ ‹µ4ÿÿÿ|±ü‰½”þÿÿ‰|$‹…ÿÿÿtü‰µþÿÿ‰t$‹½ÿÿÿu¸D¹ü‹½Pÿÿÿ‰…ŒþÿÿM´‰D$‰t$ ‰T$‰|$‰ $èüÿÿÿƒ½ÿÿÿ¤ÇE°‹•Dÿÿÿ¸‹ ‰…@þÿÿ‰Ïé³ÝØ‹…Dÿÿÿ‹•4ÿÿÿ‹µ@þÿÿ‹‹•øþÿÿ)ð‹u°ÙD‚üÙ}†·E†f ;u¬f‰E„Ùm„ÛàýÿÿÙm†é‹•àýÿÿ‹…ÿÿÿЉ…äýÿÿ‹•HÿÿÿØ ‹•øþÿÿÙD‚øÙÉÚéßàžr2‹•àýÿÿ‹…tÿÿÿÇDüF‹µLÿÿÿ‰E°9}º‰•üþÿÿvÿ…@þÿÿOˆƒ‹µÿÿÿ‹•@þÿÿ1)Ћ•øþÿÿD‚ü‰D$‹µÿÿÿ1‹µ@þÿÿ)ðL‚ü‰ $èüÿÿÿÙ]ÔÙEÔÙ…<þÿÿÙÉÝáßàž‚ñþÿÿÝÙéìþÿÿ´&º¸‹‰T$ U؉D$‰L$‰$èüÿÿÿN…’üÿÿ‹µXÿÿÿ€>G…ƒüÿÿÇE¤õÿÿÿéwüÿÿÇE¤òÿÿÿé1üÿÿ‹µ\ÿÿÿÙîÙÚéßàžu(z&º¹ƒ‰T$ ‰L$ë$ÇE¤þÿÿÿéøûÿÿ¸¾‰D$ƒ‰t$ ‰D$E؉$èüÿÿÿéüÿÿÇE¤¹¸‰L$ ‹Pÿÿÿ“!‰D$‰T$‰ $èüÿÿÿ…À…m‹Xÿÿÿ¶A…íóÿÿ‹½Dÿÿÿ¾‹Ix‹}¬‹•tÿÿÿ1À9þžÀ‰FƒÂIyðº¿u‰T$<‹•Dÿÿÿ‰|$8‹$þÿÿ‰L$4‹…Üþÿÿ‰t$,‰T$(‰D$0‹µ€þÿÿ‰t$$‹•øþÿÿ‹½ÿÿÿLºü}Œ‰L$ ‹…¨þÿÿ‰|$‹½tÿÿÿ‰D$‹…Dÿÿÿ‰t$‹µÿÿÿ‰D$ ‰|$L²ü³è‰L$‰t$‹•˜þÿÿ‰$èüÿÿÿ‹M¤…É„'‹µ8ÿÿÿÇ÷ÿÿÿéoìÿÿº¹ƒî‰T$ ‹•Pÿÿÿ‰L$‰D$‰$èüÿÿÿ…À„aðÿÿ¸º‹ð‰D$ ‹…Pÿÿÿ‰T$‰L$‰$èüÿÿÿ…À„/ðÿÿ¹¸“ò‰L$ ‹Pÿÿÿ‰D$‰T$‰ $èüÿÿÿ…À„ýïÿÿº¹ƒô‰T$ ‹•Pÿÿÿ‰L$‰D$‰$èüÿÿÿ…À„Ëïÿÿ¸º‹ö‰D$ ‹…Pÿÿÿ‰T$‰L$‰$èüÿÿÿ…À„™ïÿÿÇE¤ûÿÿÿé ëÿÿ‹xÿÿÿ¶G…FûÿÿÇE¸õÿÿÿé:ûÿÿ‹u ‹éÀúÿÿ‹•|ÿÿÿ¹¾‰t$ »‰L$‰|$‰$èüÿÿÿ…À… ûÿÿÇE¸ôÿÿÿéûÿÿÇE¸ðÿÿÿéƒúÿÿ¹¿ƒ‰L$ ‰|$‰D$M؉ $èüÿÿÿéºúÿÿ‹•ìþÿÿ‰UÀƒ½@ÿÿÿ¨‹E¼9EÀ„ù‹½`ÿÿÿÇïÿÿÿé©úÿÿ‹•8ÿÿÿ³(¿*‰t$‹ ÿÿÿ‹³‰|$D‘ü‹pÿÿÿ‰D$~‰|$ ‰L$‰4$èüÿÿÿ‰|$ ¸-“T‰D$‹4ÿÿÿ‹… ÿÿÿ‰T$‹•pÿÿÿ|ˆü‰|$‰T$‰4$èüÿÿÿéRüÿÿ‹}”³‹…<ÿÿÿ‰µÿÿÿU¼‰|$ ‹½ ÿÿÿ‰t$‰t$t‡ü‰•ôþÿÿ‰$‰t$èüÿÿÿ‰t$‹•ÿÿÿ‹Pÿÿÿ‰T$Dü‰T$‹•pÿÿÿ‰D$ ‰$èüÿÿÿ¾“M؉t$ ¸‰D$‰•ÿÿÿ‰T$‰ðþÿÿ‰ $èüÿÿÿ…À…O‹M ‹9…ÿ„L‹µLÿÿÿ¹}´‰L$‹… ÿÿÿ‹pÿÿÿ‰|$T°ü‹}”‰T$‹µôþÿÿ“‰L$‹E ‰|$ ‰t$‰D$‰$èüÿÿÿ‹U ‹:…ÿt ‹Eœ€8A„p ‹ÿÿÿ¸º‰D$ ‹µðþÿÿ‰T$‰L$‰4$èüÿÿÿ…À…[‹u ‹>…ÿ„N‹pÿÿÿ‹Jx(‹½Tÿÿÿ‹µ ÿÿÿD¾ü¶ÙÙáØ(ÿÿÿÙƒÀJyî‹…ÿÿÿº¿‰|$ ‹ðþÿÿ‰T$‰D$‰ $èüÿÿÿ…À„´ƒ½@ÿÿÿ©‹U ‹ …É…‹ÿÿÿº¿‰|$ ‹µðþÿÿ‰T$‰L$‰4$èüÿÿÿ…À„øÿÿ‹Hÿÿÿ‹µ ÿÿÿ‹}Œ‹UDŽü‹µôþÿÿ‰|$ ‹½ÿÿÿ‹‰T$‹U8‰D$‹E€‰|$‰|$‰T$ ‰L$‰t$‰$èüÿÿÿé·÷ÿÿ¸¾‰D$ ƒ‰t$éªüÿÿÙ]¬é¶ùÿÿ¿ºƒ‡‰|$ ‰T$é…üÿÿ‹…ÿÿÿ¹¾‰t$ ‹•ðþÿÿ‰L$‰D$‰$èüÿÿÿ…À„³þÿÿ‹U ‹:…ÿ„¦þÿÿ‹µÿÿÿM¬‹•Tÿÿÿ‰L$‹½ ÿÿÿ‹…pÿÿÿ‰t$ t—ü¿‰t$‰$èüÿÿÿ‰|$‹…ðþÿÿº‰T$ ‹‰L$‰$èüÿÿÿ…À…„ ‹…pÿÿÿ‹Iˆ2þÿÿ‰ð‹½ ÿÿÿ‹µHÿÿÿT·üÙƒÂÙÙÉØÈÙÉÙáÞñÙƒÀIyçéþÿÿ³‹øþÿÿ¿)‰t$‹³‹…pÿÿÿ‰|$~‰|$ ‰L$‰D$‰4$èüÿÿÿ‰|$ ‹…pÿÿÿº0‰T$‹½üþÿÿ‹¼‰L$‰D$‰|$‰4$èüÿÿÿéMùÿÿ³ìº'}À‰t$‹³‰|$»N‰T$‰äþÿÿ‰L$ ‰|$‰4$èüÿÿÿ‰|$‹äþÿÿ¸)‰D$“E¼‰T$‰L$ ‰D$‰4$èüÿÿÿéäúÿÿƒ½@ÿÿÿŽLýÿÿ³=‹ôþÿÿ¿‰t$‹³‹E”‰|$~‰|$ ‰L$‰D$‰4$èüÿÿÿ‰|$ ‹Tÿÿÿº!‰T$‹½ ÿÿÿƒ\‰D$E¼Tü‰T$‰…ôþÿÿ‰D$‰4$èüÿÿÿéÎüÿÿ‹• ÿÿÿ‹½Tÿÿÿ‹µ\ÿÿÿ‹ÿÿÿDºü‰D$ D²ü‹•pÿÿÿ‰L$‰L$‰D$‰$èüÿÿÿéÅûÿÿ‹…ÿÿÿ‹‹}€‰L$‰D$‰<$èüÿÿÿÙ]¬éÙöÿÿ‹…ðþÿÿ¹¿‰L$ ³‰|$‰t$‰$èüÿÿÿ…À…‹u¼Nˆ5üÿÿ‹…pÿÿÿ‹U´‹½Hÿÿÿ‹ÁâLÿÿÿ‹ ÿÿÿ‰•Ðþÿÿ‹…LÿÿÿT¹üLøvÙØ9Ù‹½ÐþÿÿƒÂùNyìéåûÿÿ‹ ÿÿÿ‹•Hÿÿÿ‹µÿÿÿ‹…Pÿÿÿ|‘ü‹•pÿÿÿ‰t$‰t$tü‰|$ ¿‰$‰t$èüÿÿÿ‰|$ ‹•ðþÿÿ¸‰D$‹‰L$‰$èüÿÿÿ…À…ò‹pÿÿÿ‹Jx‹EˆÙèÙ‰ðÙÁØ0ØÁÙƒÀJyòÝØÝØ‹}”‹µÿÿÿ‹•Pÿÿÿ‰|$ ‹½ ÿÿÿ‹ôþÿÿ‰t$‰t$t—ü‰t$‰ $èüÿÿÿ‰t$ ‹•Hÿÿÿ¸‰D$E¼L—ü‰L$‹ÿÿÿ»‰…ôþÿÿ‰D$‰L$‰<$èüÿÿÿ‹U ‹2…ö„݉<$‹•Lÿÿÿ¸‰D$‹ ÿÿÿu´‰t$‹µpÿÿÿD‘ü‰D$‹U”‹ôþÿÿ‰t$‹E ‰T$ ‰L$‰D$é¥ùÿÿ‹… ÿÿÿ‹‹½Tÿÿÿ‰ÿÿÿ‹•Xÿÿÿ‰L$t¸ü<‰|$‹½pÿÿÿ‰t$ ‰L$‹MЉ $H‰EÐèüÿÿÿ‰<$‹ ÿÿÿ‹•Pÿÿÿ‹…ÿÿÿT‘ü‰D$‰•ÿÿÿ‰T$ ‹•Dÿÿÿ‰D$‹…XÿÿÿÐTü‰T$èüÿÿÿ‰t$ ‹Hÿÿÿ¸‰D$ ‹½ ÿÿÿU¸‰T$‹•Lÿÿÿ³}‰4$Dü‹ ÿÿÿ‰…ÿÿÿ}´‰D$D‘ü‹•pÿÿÿ‰D$‹…ÿÿÿ‰|$‰T$‰D$èüÿÿÿ‹M¸…É„/‹µ`ÿÿÿÇøÿÿÿé¨ñÿÿ³ˆ‹M”¿+‰t$‹³‹•ôþÿÿ‰|$~‰|$ ‰L$‰T$‰4$èüÿÿÿ‰|$ ‹•Tÿÿÿ¸7‰D$‹½ ÿÿÿ‹´‰L$M¼D—ü‰D$‰ôþÿÿ‰L$éüÿÿ‹• ÿÿÿ‹µÿÿÿ‹Tÿÿÿ‹…ÿÿÿ‰t$tŠü‹\ÿÿÿ‰D$‰t$ DŠü‹pÿÿÿ‰D$‰ $èüÿÿÿÙ…(ÿÿÿ‰t$‹pÿÿÿUÌØ}¬‰T$‹…ÿÿÿ‰ $‰D$ Ù]Ìèüÿÿÿ‰t$‹•ôþÿÿ¸‰D$‹u”‹ÿÿÿ‰T$‰t$ ‰L$‰<$èüÿÿÿés÷ÿÿƒ½@ÿÿÿ~‹µ$ÿÿÿ…öte‹½pÿÿÿ¹‰0ÿÿÿ‹‰•,ÿÿÿJu/ëGv‹•,ÿÿÿ‹M˜‹|‘ü…ÿ…ÍJ‰•,ÿÿÿ‹•,ÿÿÿ9•0ÿÿÿ}‹½0ÿÿÿ‹E˜‹t¸ü…ötÅG‰½0ÿÿÿë؃½@ÿÿÿ·‹}”‹Pÿÿÿ‹µ ÿÿÿ‰|$ ‹…ÿÿÿ}¼‰½ôþÿÿTŽü‰D$‰D$‰T$‰<$éöÿÿ‹½ðþÿÿ¸¹‰D$ “‰L$‰T$‰<$èüÿÿÿ…À…Ì‹½pÿÿÿ‹Jˆóûÿÿ‹MˆÙè‰ðÙÙÙÁØÉÙÉØãÞùÙƒÀJyìéÍûÿÿ‹•ðþÿÿƒ‡¿‰|$ ¾‰t$‰D$‰$èüÿÿÿ…À„¯úÿÿ‹U ‹2…ö„áöÿÿ‹ðþÿÿƒ¾‰t$ ¿‰|$‰D$‰ $èüÿÿÿ…À…¯öÿÿ‹u¼Nˆ¥öÿÿ‹½pÿÿÿÙè‹U´‹Hÿÿÿ‹Áâ…Lÿÿÿ‹… ÿÿÿ‰•Ðþÿÿ‹½LÿÿÿTˆüL¸øÙØáØ9Ù‹…ÐþÿÿƒÂÁNyêÝØéRöÿÿt&‹• ÿÿÿ}¸‹Tÿÿÿ‰½ ÿÿÿ‹…Hÿÿÿ‰|$|Šü‹pÿÿÿ‰|$‹1‰ $ðD‚ü‰D$‹…Lÿÿÿu´‰µÿÿÿ‰t$ t‚ü‹…ôþÿÿ‰t$‰D$èüÿÿÿ‹… ÿÿÿº ¹‰T$4‹U€‰L$0‹ÿÿÿ‰D$,‹‹•hÿÿÿ‹pÿÿÿ‰D$(‹…lÿÿÿ‰T$$‰D$ ‹‰t$‹…Hÿÿÿu¼‰t$‹ÿÿÿЉL$‹• ÿÿÿ‹ë‰L$D‚ü‹U€‰D$‹…pÿÿÿ‰T$‰D$ ƒö‰$èüÿÿÿ‰µôþÿÿ‹MŒº‰T$‹E‹•hÿÿÿ‰L$‹lÿÿÿ‰D$‹E€‰T$“û‰L$ ‰$‰t$‰D$èüÿÿÿ‹pÿÿÿ‹‰Ñƒéx‰øǃÀIyô‹½Tÿÿÿ¸€?¹ú‹½ ÿÿÿ‰D—øº ‰L$0‹… ÿÿÿ‰T$4‹TÿÿÿU°‰T$(‹•pÿÿÿ‰D$,Dü‰T$$‰D$ ‹ ‰t$‹…Hÿÿÿ‹•Lÿÿÿ‹µpÿÿÿÈ‹ÿÿÿ‰t$D‡ü‰D$‹… ÿÿÿ‰L$‹ÿÿÿ|ü‰|$ƒþ“‰L$ ‰D$‰$èüÿÿÿénóÿÿ‹½0ÿÿÿ‹Pÿÿÿ‹…,ÿÿÿ‹•Pÿÿÿù‹½ ÿÿÿ‹tø‹D—ø‰u°‰Dø‰t—ø‹ ÿÿÿ‹•Hÿÿÿ‹µÿÿÿ|‘ü‹•pÿÿÿ‰t$‰t$‹µ0ÿÿÿ‰|$ ‹N‰$¯Æ…LÿÿÿDü‰D$èüÿÿÿ‹•ÿÿÿ‹Lÿÿÿ‰T$‹•pÿÿÿ‹‰$¯ð΋ ÿÿÿt±ü‰t$ ‹µÿÿÿ‰t$‹µ,ÿÿÿN¯Æ…LÿÿÿDü‰D$èüÿÿÿ‹•ÿÿÿ‹Lÿÿÿ‰T$‹•pÿÿÿ‹‰|$‰$¯ÆÈ‹ ÿÿÿDü‰D$ ‹…ÿÿÿ‰D$èüÿÿÿÿ…0ÿÿÿ‰µ,ÿÿÿéûÿÿ“ ‹Pÿÿÿ¸'‰T$‹“‹½ ÿÿÿ‰D$rDü‰t$ ‹µpÿÿÿ‰D$‰$‰t$èüÿÿÿéþúÿÿ‰|$‹ÿÿÿ‹…ÿÿÿ‹µLÿÿÿ‹• ÿÿÿ‰L$ ‹pÿÿÿ‰D$‹9‰ $þD²ø‰D$³4èüÿÿÿ‰t$‹³¿-‰|$‹ÿÿÿ‹…pÿÿÿ‰4$~‰L$‰|$ ‰D$èüÿÿÿ‰|$ º0‹…ÿÿÿ‰T$‹•pÿÿÿ‹d‰L$‰D$‰T$‰4$èüÿÿÿéÐùÿÿ‹ðþÿÿ¸“‰D$¿‰|$ ‰T$‰ $èüÿÿÿ…À…¹‹•pÿÿÿ‹ Iˆ|ñÿÿ‹EˆÙ苽 ÿÿÿÙ‰ð‹µHÿÿÿT·üÙÙÙɃÂÙáÙÉØãÙÉØÊÙÉØÈÞùÙƒÀIyßÝØÝØé9ñÿÿ‹•ðþÿÿ¹ƒ‡‰L$ ¿‰|$‰D$‰$èüÿÿÿ…À…öÿÿ‹…pÿÿÿ‹Jˆõõÿÿ‹}ˆÙè‰ðÙÙÙÀØÃÙÉØãÙÉØÊÞñÙƒÀJyèéËõÿÿ‹ðþÿÿ¸“‡‰D$ ¿‰|$‰T$‰ $èüÿÿÿ…À… ðÿÿ‹•pÿÿÿ‹ Iˆ‘ðÿÿ‰ð‹½ ÿÿÿÙ苵HÿÿÿT·üÙƒÂÙØñÙÉØâÞÉÙáÙƒÀIyçÝØé]ðÿÿLMSMLASABEEpsilon-MachineREGULRSHIFTI_seupd: Ritz values passed in from _SAUPD._seupd: Ritz estimates passed in from _SAUPD.BUCKLECAYLEY_seupd: Ritz values after calling _SGETS._seupd: Ritz value indices after calling _SGETS._seupd: Number of specified eigenvalues_seupd: Number of "converged" eigenvalues_seupd: Converged Ritz values_seupd: Associated Ritz estimatesIdentity_seupd: Untransformed converged Ritz values_seupd: Ritz estimates of the untransformed Ritz valuesNotransposeRightAllTransposeLeft_seupd: The eigenvalues of H--reordered_seupd: NCV Ritz values of the final H matrix_seupd: last row of the eigenvector matrix for H€?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@E ü"° %ˆ+ˆ4ˆ0 ¬& >Œ”F S(z,Š,#O“<° ì! ñÿ  #(  <B HOEW n„ `òÿ‹‘™¥¬³ºÂÈÏÖÝåíõý |òÿsseupd.ft0.0t1.1t2.2t3.3t4.4t5.5__g77_forceload_0.6.LC11.LC22sswap_sseupd___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_debug_s_cmpslamch_powssgets_s_copysvout_scopy_ssesrt_sger_sscal_ivout_snrm2_ssortr_ssteqr_sgeqr2_sorm2r_slacpy_timing_ ¯: JŒ ¦Å Òñ þ *ä P£ ³ö 6 M‘ ¦ËÚ  M{† ®ü   V È  H r !‹ ¬ ã 0 "I U ¢ · Ø ÷  ( 2 O #h  #— ¬ Ê é M ^ q $“ £ Ha mÒü %y ¹ÿ+ j&Œ ž¿Þ @o"Ÿ% ‘Ö ô 3'u ˜  (Ö ê)£ © ¹(=’Óê ÿ*n s}©È Üò v Ý össesrt.o/ 1189291776 1000 1000 100644 2304 ` ELF4( U‰åWVSƒìl‹M ‹EèüÿÿÿËU‹}‰Mð‹M‰Eì‹E ‰Uè‹u‰MÔ‹‰}ä‹}ì‰U຋‰T$ ‰4$‰ÈÁè<¹ƒ‰L$Ñÿ‰D$èüÿÿÿ…À…Ï…ÿ„­‰}Ü‹Uì‰þ÷Ö2‰u؈‡ƒ‰EЋuÜë )þ…öx^‹Uè >ٲيÝáßàžvlÙ²‹EðÙŠ‹…ÒtØ‹Eà‹UЯÁ‰T$‹UÔ ‚‰L$ ‹Mà‹EЯÎ)þ‰D$Š‹Mä‰D$‰ $èüÿÿÿ…öy¢ÿEÜÿMØy‚‰þÁî÷Ñÿ…ÿ…SÿÿÿƒÄl[^_]ÃÝØÝØÿEÜÿM؉YÿÿÿëÕ‰4$º¸‰T$ ‹‰D$‰L$èüÿÿÿ…À…Å…ÿt¶‰}´‹Mì‰þ÷Ö1‰üšƒ‰EÈ‹u´´&)þ…öxt‹Uè‹Eè‹ ²>‰M¨ÙÙE¨ÙÁÙÉÙáÙÉÙáÚéßàžvh‹EèÙ°‰ ‹Eð‹…Ét‹Mà‹EȯʉD$‹UÔŠ‰D$ ‹Eà‹MȯÆ)þ‰L$ ‚‹Uä‰L$‰$èüÿÿÿ…öyŒÿE´ÿM̉oÿÿÿ‰þÁî÷Ñÿé?ÿÿÿÝØëâ‰4$¸¹‰D$ “‰L$‰T$èüÿÿÿ…À…«…ÿ„Áþÿÿ‰}°‹Uì‰þ÷Ö2‰uĈ€‹‰MÀ‹u°)þ…öxf‹Uè >ٲيÙÉÝáßàž†TÙÉٲي‹Uð‹…ÀtЋEà‹UÀ¯Á‰T$‹UÔ ‚‰L$ ‹Mà‹EÀ¯Î)þ‰D$Š‹Mä‰D$‰ $èüÿÿÿ…öyšÿE°ÿMÄy‰‰þÁî÷ÑÿéUÿÿÿ‰4$º¸‰T$ ‹‰D$‰L$èüÿÿÿ…À…òýÿÿ…ÿ„êýÿÿ‰}¬‹Mì‰þ÷Ö1‰u¼ˆ˜ƒ‰E¸‹u¬)þ…öxz‹Uè‹Eè‹ ²>‰M¨ÙÙE¨ÙÁÙÉÙáÙÉÙáÙÉÚéßàž†‹EèÙ°‰ ‹Eð‹…Ét¼‹Mà‹E¸¯Ê‰D$‹UÔŠ‰D$ ‹Eà‹M¸¯Æ)þ‰L$ ‚‹Uä‰L$‰$èüÿÿÿ…öy†ÿE¬ÿM¼‰qÿÿÿ‰þÁî÷Ñÿé=ÿÿÿfÝØÝØÿE°ÿMĉzþÿÿéìþÿÿÝØëËSASMLALM‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ p %\+\0\8dEhll|l#…  Qñÿ  .DJssesrt.f.LC1ssesrt___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_cmpsswap_  ] l— Z gŽ K Xƒ ñ" /Z Üdgetv0.o/ 1189291776 1000 1000 100644 4544 ` ELFü4( U‰åWVSƒìl‹M ‹E èüÿÿÿËU‹}‰MÔ‹M4‰Eà‹E(‰Uä‹u‰}Ü‹U$‰M¼‹},‰EÌ‹ƒ‰uØ‹u0…À‰UЋU8‰}ȉuĉUÀt4º¸¿‰“ ¾1ɉƒ$‰»(‰³,‰‹‹Mä‹1…ö„ñ‹uඋ‹…É„Û'I%u"¹"Ê Ò!Ø Þ%ä õ%û dlaqrb.o/ 1189291776 1000 1000 100644 5368 ` ELFP4( U‰åWVSìÌ‹U‹M èüÿÿÿËE‹}‰U„‹U ‰M€‹M$‰…xÿÿÿ‹E‰½ÿÿÿ‹u‰•øþÿÿ‹U€‰ôþÿÿ‹},‰…tÿÿÿ‹‰µ|ÿÿÿ‹u(‰…hÿÿÿ‰½lÿÿÿ‰µpÿÿÿ‹2Ç…ö„> ‹…|ÿÿÿ‹xÿÿÿ‹8‹9Ç„1 ‰ñƒéx‹•pÿÿÿÇÇBƒÂIyíÙƒ)øº ‹pÿÿÿ@}¸‰…HÿÿÿÝTñø³‰T$‰4$ÝxþÿÿèüÿÿÿÝ…xþÿÿÙÉE°ÝU°ÞùÝ]¸‰|$‰$èüÿÿÿ¹ “ ‰L$‰$èüÿÿÿ‹u„Ý ÿÿÿÛ…Hÿÿÿ‹>ܵ ÿÿÿ…ÿÜM°Ý0ÿÿÿ„º‹E€¿¾‰½dÿÿÿ‹‰•`ÿÿÿƒêx)¹‹½ÿÿÿ1FÇÇÇDÇ‹…hÿÿÿÁJyÜ‹xÿÿÿ‹½|ÿÿÿ‹‹7‰•¤þÿÿ‹•Hÿÿÿ‹½Hÿÿÿ‹¤þÿÿÁâ)úÒ‰•\ÿÿÿ‰ þÿÿ‰µPÿÿÿ‹ þÿÿ9Î׋µ\ÿÿÿ1À‰…Xÿÿÿ…ö‰µÿÿÿˆ­E¨‹•hÿÿÿ»‰…Äþÿÿ‰Èqÿ‰½Àþÿÿ‹½hÿÿÿƒè‰µèþÿÿ¯Â‰ò¯×u¤ȉ…ÿÿÿ}˜ʉ•ÿÿÿ‹Eȉ¼þÿÿUÐMĉ…¸þÿÿ‰µ´þÿÿ‰½°þÿÿ‰•¬þÿÿ‰¨þÿÿ‹µPÿÿÿ‹ þÿÿ)ñ‹µ þÿÿ‰ÏO‰µTÿÿÿˆ ‹…Pÿÿÿ‹•hÿÿÿ‹ÿÿÿH¯ÂÁ‹PÿÿÿTÈø‰ð‰•ÿÿÿ)È@‰…ÿÿÿ‹•Àþÿÿ‰• ÿÿÿë$fÝÙÙÉÚéßàžƒ¸‹µäþÿÿO‰µTÿÿÿˆ¥‹µTÿÿÿ‹…hÿÿÿ‹•Tÿÿÿƒî‹Tÿÿÿ¯ÆIЋ•ÿÿÿÝDÂð‰È‰äþÿÿ‹hÿÿÿÙá¯Á‹TÿÿÿÈÝDÂøÙáÞÁÙîÙÉÝáßàÝÙž„Ý… ÿÿÿ‹…hÿÿÿ‹•TÿÿÿÞɯðÝ…0ÿÿÿÙÉ ‹µÿÿÿÝáßàžÝDÎøÙá‚FÿÿÿÝÚÚéßàž‚Hÿÿÿ‹½|ÿÿÿ‹Tÿÿÿ‹7‰Pÿÿÿ9Î}"‹•hÿÿÿ‰È1ÿƒè¯Â‹•ÿÿÿÈ1ɉ|Âø‰LÂü‹Tÿÿÿ9èþÿÿŽ¿‹u„‹…Àu‰dÿÿÿ‹ þÿÿ‰`ÿÿÿƒ½Xÿÿÿ ”Àƒ½Xÿÿÿ” Ш„‹• þÿÿ‹hÿÿÿ‹… þÿÿƒê‹½ÿÿÿ¯Ê‹µÿÿÿÁÝDÏøÝD÷ðÙÉÙáÙÉÙáÞÁÙÀÙÁÙÉØ‹ÙÉØ‹ÙÉÞÊÝ•@ÿÿÿÝ8ÿÿÿ‰•Lÿÿÿ+•Tÿÿÿ‰•œþÿÿˆa‹½Lÿÿÿ‹hÿÿÿ‹µhÿÿÿƒï‹•hÿÿÿ¯ù‹Lÿÿÿ¯Î‹µLÿÿÿ‰ÈN)Љ…Ìþÿÿ‹…hÿÿÿ‰µÈþÿÿ÷؉…lþÿÿt&Ý…@ÿÿÿ‹µLÿÿÿ‹•ÌþÿÿÝ…8ÿÿÿ‹…ÿÿÿò‹µLÿÿÿÝDÐø1ÜêÜ鋵ÿÿÿÙÂÝÆÙÉØËÙÁÝDÆÙÉØäÙÊØçÜ4ÖÙÊÞæÙÉÜDÆøÙÍ‹…TÿÿÿÞä9…LÿÿÿÙÄÙÄÙáÙÉÙáÞÁÙÁÙáÞÁÜýÜüÞùÙÌÝUÈÙËÝUÐÙÌÝUØ„ÙÊ‹•LÿÿÿÙáÙÉÙáÙËÙáÙÌÙáÝDÆðÙËÙáÝDÆøÙÌÙáÙÊÞÁÙËÙáÙÉÞÂÞÊÞÂÙÊÞÉÜ ÿÿÿÚéßàžs/‹…Èþÿÿ‹µlþÿÿµÌþÿÿ‰…LÿÿÿñH‰…Èþÿÿ÷ÿœþÿÿ‰ïþÿÿÝØ‹ þÿÿ‹•Lÿÿÿ‹½Lÿÿÿ)ÑI‰½˜þÿÿ‰ÿÿÿˆj‹µ þÿÿ‹…dÿÿÿ)Ɖµüþÿÿé‹…Pÿÿÿ9…LÿÿÿŽ5‹µ˜þÿÿ‹hÿÿÿ‹•˜þÿÿƒî‹½ÿÿÿ¯ñÖ€t÷ÿ€‹E¤ÝE˜ÝEЃøÙÁØÉ„‹˜þÿÿAƒø‰àþÿÿ„~ÝØÝØÝØÿÿÿÿ‹½àþÿÿ‰½˜þÿÿˆÐ‹ þÿÿ‹½˜þÿÿ)ùAƒù‰M¤~ÇE¤‹•Lÿÿÿ9•˜þÿÿÜ‹•°þÿÿ‰T$‹½¼þÿÿ‰|$ ‹¬þÿÿ‰L$‹…¸þÿÿ‰D$‹µ´þÿÿ‰4$èüÿÿÿ‹•Lÿÿÿ9•˜þÿÿŽÿÿÿÝEÈ1É‹…˜þÿÿ‹•hÿÿÿ‹½˜þÿÿƒè¯Âø‹½ÿÿÿÝ\ÇøÇljLÇ‹µ˜þÿÿ9µèþÿÿ~ 1É1ö‰LljtÇ ÝE˜‹E¤ÝEÐÙÁƒøØÉ…ðþÿÿÝEØ‹•`ÿÿÿ+•˜þÿÿÝ•þÿÿØËÝ(ÿÿÿˆÒÙÊÝ•Ðþÿÿ‹…˜þÿÿ‹hÿÿÿ‹µ˜þÿÿH‹½ÿÿÿ¯Á‹hÿÿÿðÁáÇëÝ…ÐþÿÿÝÝ@Ý…þÿÿÙÂØÍÝ@øÙÊØËÙÉØÂÞÁÙÀÙÍØÉÙÍØÏÙÊÞåÙËÞáÙËÝXøÙÊÝÜ(ÿÿÿÞéÝXÈJy³ÝE˜‹…˜þÿÿƒÀ;… þÿÿ~‹… þÿÿ‹µdÿÿÿ‹•˜þÿÿB‰•àþÿÿ)ð‰…hþÿÿˆ­‹…˜þÿÿH‰…ŒþÿÿëfÝE˜Ý…þÿÿ‹•hÿÿÿ‹…Œþÿÿ‹˜þÿÿ¯Â‹•hÿÿÿ¯Ñð‹ÿÿÿ‰…pþÿÿ‹…àþÿÿò¯…hÿÿÿ‹½pþÿÿÝDÑøÝDùøÙÉØÌÙÊðFÜLÁøÙÊØÁÞÂÙÊØÉÙÁØÍÙËÞáÝ\ùøÙÉÜlÑøÝ\ÑøÜ(ÿÿÿÜlÁøÝ\Áøÿhþÿÿ‰gÿÿÿÝE˜Ý…þÿÿ‹½˜þÿÿ‹µpÿÿÿÝþÝDþÝDþøÙÂÞÎÙËØÉÙÍØÃÞÅÙËØÌÙÍØÌÙÌÜ(ÿÿÿÙÊÞåÞãÙËÝ\þøÞâÝþÝ\þÿÿÿÿ‹½àþÿÿ‰½˜þÿÿ‰0ýÿÿÿ…Xÿÿÿÿÿÿÿ‰Óøÿÿ‹µ þÿÿ‹…lÿÿÿ‰0ÄÌ[^_]Ë…hÿÿÿOÿ‹µÿÿÿ¯È‹…øþÿÿÝDÖø1É1ÒÝ\øø‹µôþÿÿ‰Lþø‰TþüÄÌ[^_]˵xÿÿÿ‹½|ÿÿÿ‹‰•¤þÿÿ‰Ð‹7¿)ð‰Áƒéˆ{÷ÿÿ‹•hÿÿÿFÿ¯Âð‰…dþÿÿ‹…dþÿÿ‹•ÿÿÿø‰…tþÿÿGÇÂÇD‹…hÿÿÿ…dþÿÿIyÍé/÷ÿÿŠæøÿÿÝع‹…tÿÿÿ‰L$‹•Äþÿÿ‰D$ ‰T$‹ÿÿÿ‰L$‹•ÿÿÿ‹…¨þÿÿ‰UĉD$‹ ÿÿÿ‰ $èüÿÿÿé—øÿÿ¶‹¼þÿÿ‰L$‹½¸þÿÿ‰L$‰|$ ‹•˜þÿÿ‹…hÿÿÿ‹µÿÿÿƒê‹½˜þÿÿ¯Ð ÖDùø‰D$‹µ´þÿÿ‰4$èüÿÿÿéÐûÿÿ‹•`ÿÿÿ+•˜þÿÿˆf‹…˜þÿÿÙ‹hÿÿÿ‹½˜þÿÿH‹µÿÿÿ¯Á‹hÿÿÿøÁáÆëÙÂÝÝ@øÙÁØÍØÁÜÎØÌÙÉÞæÞéÙÌÝXøÙËÝÈJyÛÝÚÝE˜‹µüþÿÿ‹•˜þÿÿ‹dÿÿÿJ…ö‰•hþÿÿyëYvÝE˜‹…hþÿÿ‹•hÿÿÿ‹½˜þÿÿ¯Ð‹…hÿÿÿ¯Ç‹½ÿÿÿÊÈÝDÇøANÝD×øÙÉØËØÁÜÊØÌÙÉÞâÙÉÝ\×øÜlÇøÝ\Çøy­ÝE˜‹˜þÿÿ‹•pÿÿÿqÝÊÝDÊøÙÁÞÌÜÃÙÊØËÙËÞÌÙÉÞâÞâÝ\ÊøÝʉµàþÿÿéjúÿÿ‹½ÿÿÿ‹•ÿÿÿ‹…hÿÿÿ‹ þÿÿ‹µÿÿÿÝDúø‹• þÿÿ‹½ÿÿÿÝ8ÿÿÿƒê¯ÂÈÝDÇðÝ@ÿÿÿÝD÷ðÜLÇøéó÷ÿÿÙÊé«ûÿÿÙÊéëþÿÿÝØÝØÝØÝØÝØéOùÿÿ‹ þÿÿ9Tÿÿÿt,‹…Tÿÿÿ9…èþÿÿte‹Xÿÿÿ‹…Tÿÿÿ)\ÿÿÿH‰… þÿÿéÝôÿÿ‹•hÿÿÿ‹èþÿÿ‹½Tÿÿÿ¯Ê‹•ÿÿÿ‰Èø‹øþÿÿ1ÿÝDÂø‹…Tÿÿÿ1ÒÝ\Áø‹ôþÿÿ‰|Áø‰TÁüë›Muˆ‰Øþÿÿ‰L$$‰µÜþÿÿ‰t$ ‹µ þÿÿ‹…ôþÿÿÁæ yø‰|$ƒé‹•øþÿÿ‰L$<Gø‰D$ƒï‰|$‹•Tÿÿÿ‹hÿÿÿ¯Ê‹•ÿÿÿ<ʉ½ðþÿÿ‰ùñAøƒé‰D$ ‹… þÿÿ‹½hÿÿÿƒè¯Ç<‰½ìþÿÿ‰úò‰L$Bøƒê‰D$‰$èüÿÿÿ‹M„‹9…ÿ„Á‹• þÿÿ}Ä9•`ÿÿÿ¹‹•Øþÿÿ‰T$‹Üþÿÿ“‰T$‰L$‹dÿÿÿ‹µðþÿÿ‰T$ÁáDø‰D$ ‹…ìþÿÿtø‰t$‹•dÿÿÿ‹… þÿÿ)ÐH‰Eĉ<$èüÿÿÿÝEˆ‹µpÿÿÿ‹ þÿÿÝE‹•|ÿÿÿÝDÎðÝDÎøÙÁÙÁÙÉØÍÙÉØÌÙÊÞÍÙÊÞËÞÁÙÊÞáÙÉÝ\ÎðÝ\Îø‹2éþÿÿ‹½|ÿÿÿ‹7éþÿÿ‹…Øþÿÿ‰D$‹½Üþÿÿ‰|$‹½tÿÿÿ‰|$‹ þÿÿ‹…hÿÿÿ‹•ÿÿÿ‰|$¯Á Âñqøƒé‰t$ ‰L$‹½`ÿÿÿ‹… þÿÿ)lj}Ä}ĉ<$èüÿÿÿéÜþÿÿsafe minimumprecision1€?@?ྋ$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@; `˜ %|+|0|8”E¤l¨|¨#Ë…X€  ؈ñÿ   ;&=S[cksz‚dlaqrb.f.LC1.LC7.LC6.LC5dlaqrb___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_dlamch_dlabad_dlarfg_dlanhs_dcopy_dlanv2_drot_ À á ó ) X | „ 6Ñ + ñ ) t2dstqrb.o/ 1189291777 1000 1000 100644 6976 ` ELFø4( U‰åWVSìì‹U‹u èüÿÿÿËM‹}‰U€‹E‰µ ÿÿÿ‹u‰ÿÿÿ‹U€‰½ÿÿÿ‰µÿÿÿ‰…|ÿÿÿÇ‹…À„³H„·º³»‰T$‰4$èüÿÿÿ¹Ý•@ÿÿÿØÈÝ8ÿÿÿ‰L$‰<$èüÿÿÿ‹E€Ý(ÿÿÿكܵ(ÿÿÿÙúسÝ]ÐÝ…(ÿÿÿÙúܵ8ÿÿÿÝ]À‹0‰òƒêx‹…ÿÿÿÇÇ@ƒÀJy틽ÿÿÿ‰ò1ÉÁâ¸ð?)ò‰L÷øÒ1ɉD÷ü¿Fÿ‰•$ÿÿÿ‰pÿÿÿ‰½hÿÿÿ‰…Tÿÿÿ;µhÿÿÿŒ6ƒ½hÿÿÿ~‹•hÿÿÿ1ÿ1À‹ÿÿÿ‰|Ñð‰DÑô‹½Tÿÿÿ9½hÿÿÿ’‹…hÿÿÿ‰ù)Á‰…Xÿÿÿˆ|Ùƒ‹½ ÿÿÿÁà8‹½ÿÿÿD8ø‰…Hþÿÿ¶‹½HþÿÿÝÙáÝáßàžz„«ÝBøÝÙÉÙáÙÉÙáÙÉÙúÙÉÙúÞÉÜ@ÿÿÿÚéßàžƒŒÿ…XÿÿÿƒÂƒ…HþÿÿIy®Ý؉µXÿÿÿ‹Xÿÿÿ‹•hÿÿÿ‰Ï‰•\ÿÿÿG9щ•lÿÿÿ‰`ÿÿÿ‰dÿÿÿ‰½hÿÿÿ„ôþÿÿ¾‰ÑÁá‰t$‹…ÿÿÿ|ø‰½¤þÿÿEì‰|$ ‹µ ÿÿÿ|1ø‰|$‹‹•\ÿÿÿ‹µ`ÿÿÿ)Ö‰µÿÿÿF‰uì‰D$‰ $èüÿÿÿÙÀ1ÒÝ]ÈÙƒÙɉ•tÿÿÿÝáßàÝÙžz„¢ÝEÐÙÉÝáßàÝÙž‡z ÝEÀÚéßàž‡N ‹µ ÿÿÿ‹Xÿÿÿ‹½lÿÿÿÝDÎøÝDþøÙÉÙáÙÉÙáÚéßàžv‰lÿÿÿ‹•\ÿÿÿ‰•dÿÿÿ‹…lÿÿÿ‹lÿÿÿ@9dÿÿÿ‰…¸þÿÿŽ`¶‹½dÿÿÿ9½lÿÿÿto‹•lÿÿÿ‰þN‰ñ)щ•”þÿÿxZ‹½ ÿÿÿ‰Ð‹µÿÿÿÁà8|0øt&ÝBøÝÝÙÊÙáÙÉÙáÙÉÜ8ÿÿÿÙÊÙáØÈÙÊÞÉÜ…(ÿÿÿÚéßàžsÿ…”þÿÿƒÇƒÂIyË•dÿÿÿ‰•”þÿÿ‹dÿÿÿ9”þÿÿ}‹µ”þÿÿ1Ò1À‹½ÿÿÿ‰T÷ø‰D÷ü‹lÿÿÿ‹• ÿÿÿ9”þÿÿÝDÊøÝ0ÿÿÿ„)‹½”þÿÿ9½¸þÿÿ„U‹½$ÿÿÿ9½pÿÿÿ„ ÿ…pÿÿÿU˜‹…lÿÿÿÝ…0ÿÿÿ‹µÿÿÿ»‹ ÿÿÿÝDÆøÙÉÜ,ÁÙÉØÀÞùÝ]˜‰|$‰•¨þÿÿ‰$èüÿÿÿÙƒÙÁ‹”þÿÿÝ]ÙÉ‹µ ÿÿÿÙáÝE˜Ý…0ÿÿÿÜlÎøÙÉÝãßàž‚~ÞÂÙÉ‹•lÿÿÿ‹½ÿÿÿ‹…”þÿÿ‹µ”þÿÿÜ|×øÙÊ)ЉÇNO‰µ´þÿÿÝ€þÿÿÞÁÝ]˜ÙƒÙÀÝU¸ÝU°ˆM¸U°‰þÿÿE‰•ŒþÿÿMˆ‰…¬þÿÿ‰°þÿÿëÙÉ‹ÿÿÿ‹•¬þÿÿÝDñøÜÉÞÊÝ]ˆÝHÿÿÿ‰T$‹…þÿÿ‰D$ ‹Œþÿÿ‰L$‹•°þÿÿ‰T$‹…¨þÿÿ‰$èüÿÿÿ9µ´þÿÿt ÝE‹…ÿÿÿÝðÝ…€þÿÿ‹ ÿÿÿ‹E€ÝE°ÙÉÜ,ñÝDñøÙÂØÃÝE¸ÙÊØãÙÉÜHÿÿÿÙÉØÊÙËÝU˜ÙËÞÁÙÁØÉÙÉÝUØÌÙËØÁÙÉÝ€þÿÿÙÁÙàÙÉÝñÙÊ‹•ÿÿÿÜ¥HÿÿÿÝ]˜ÙÊÝTòøÙÉ‹‹•ÿÿÿñNOÝ\Êð‰ÿÿÿÝØÝØ‹µlÿÿÿ¹¸)µ”þÿÿº‹½”þÿÿG‰}„‰L$$‹‰D$,‰T$(‰òÁâ‰L$ ‹½ÿÿÿD:ø‰D$‰ð‹u€‹>‹µÿÿÿ‰L$ ø‹‰L$|ÆðD2ø‰|$³}„‰|$“‰t$‰D$‰$èüÿÿÿÝ…€þÿÿ‹½lÿÿÿ‹… ÿÿÿÜløøÝ\øø‹µÿÿÿÝE˜Ý\þøéaüÿÿ‹}€‹ƒêx'Ùƒ‹ÿÿÿÝÝéßàžzt‹µ|ÿÿÿÿƒÁJyçÝØÄì[^_]ÃÇÇFð?Äì[^_]ÃÞâé}ýÿÿÝ…0ÿÿÿ‹•lÿÿÿ‹ ÿÿÿÝ\Ñø‹…¸þÿÿ‹µdÿÿÿ‰…lÿÿÿ9ðÖx‰½¸þÿÿéÈûÿÿM¸u°‰L$E¨‰t$} ‰|$ ‰D$‹…lÿÿÿÁà<‰|$‹µÿÿÿƒï‰<$D0ø‰D$èüÿÿÿÝE°‹½lÿÿÿ‹ÿÿÿÝE¸ÙÉ‹U€‰øÝTùø‹ÿÿÿÙÀÙÊ‹2ðÝTÁð‹•ÿÿÿ1É1ÀÝDúøÝúÙÁØËÙÍØÉÙËÞÉÙÉÞËÙÉÞãÞÁÙÉÝúÝ\úø‹µ ÿÿÿÝE Ý\þøÝE¨Ýþ‹•ÿÿÿ‰Lúø‰Dúü‹µdÿÿÿƒÇ‰½lÿÿÿ9÷ìW‰•¸þÿÿéÞúÿÿÝØ‹U€‹2;µhÿÿÿÊøÿÿºƒî‰•xÿÿÿ‰µàþÿÿˆþÿÿ‰µ þÿÿ‹½ÿÿÿ¸‰…œþÿÿ‹ ÿÿÿ‰½˜þÿÿ‰Dþÿÿ‹•œþÿÿ‹µDþÿÿ‹ þÿÿ‰•LþÿÿÝ…ÉÙÀxI‹•xÿÿÿ‹… ÿÿÿ|Ðø‰½HþÿÿëÝ؉•Lþÿÿƒ…HþÿÿBIx‹µHþÿÿÝÙÊÝâßàžwÜÝÚƒ…HþÿÿBIyâ‹œþÿÿ9Lþÿÿ„g‹…Lþÿÿ‹ ÿÿÿÝ\Áø‹µDþÿÿÝ‹½ÿÿÿ‹•˜þÿÿÝDÇøÝÝ\ÇøÝÿ…xÿÿÿÿ…œþÿÿƒ…Dþÿÿƒ…˜þÿÿÿ þÿÿÿàþÿÿ‰)ÿÿÿÄì[^_]Ë…lÿÿÿH‰…¼þÿÿ‰ö¼'‹dÿÿÿ9lÿÿÿ„€‹…lÿÿÿ‹•dÿÿÿ‹½lÿÿÿ)ЉÁIxg‹µ ÿÿÿ‰øÁàT0ð‹µÿÿÿD0ð‰…Hþÿÿ¶ÝB‹µHþÿÿÝÙÉÙáÝÙÊÙáÙÉÜ8ÿÿÿÙÊÙáØÈÙÊÞÉÜ…(ÿÿÿÚéßàžsƒ­HþÿÿOƒêIy¾‹½dÿÿÿ;½dÿÿÿ~‹ÿÿÿ1À1Ò‰Dùð‰Tùô‹lÿÿÿ‹µ ÿÿÿ9ÏÝDÎøÝxþÿÿ„Á9½¼þÿÿ„÷‹$ÿÿÿ9pÿÿÿ„¢ÿ…pÿÿÿ‹‹…lÿÿÿÝ…xþÿÿ‹µÿÿÿ‹• ÿÿÿÝDÆðÙÉÜlÂðÙÉU˜ØÀÞùÝ]˜‰L$‰•tþÿÿ‰$èüÿÿÿÙƒÙÁ‹µ ÿÿÿÝ]ÙÉÙáÝE˜Ý…xþÿÿÜlþøÙÉÝãßàž‚!ÞÂÙƒÙÊ‹µÿÿÿ‹…lÿÿÿ‹¼þÿÿÜ|ÆðÙÊ)ù‰þ‰üþÿÿÝU¸ÙÉÞÂÝU°ÙÊÝXþÿÿÝ]˜ÙÀˆU¸E°‰•lþÿÿM‰…hþÿÿUˆ‰pþÿÿ‰•dþÿÿëÙÉ‹•ÿÿÿ‹…pþÿÿÝDòøÜÊÞÉÙÉÝ]ˆÝPþÿÿ‰D$‹lþÿÿ‰L$ ‹•hþÿÿ‰T$‹…dþÿÿ‰D$‹tþÿÿ‰ $èüÿÿÿ9þt ÝE‹ÿÿÿÝ\ñðÝ…Xþÿÿ‹… ÿÿÿ‹M€ÝE°ÙÉÜlðøÝðÙÂØÃÝE¸ÙÊØãÙÉÜPþÿÿÙÉØÊÙËÝU˜ÙËÞÁÙÁØÉÙÉÝUØÌÙËØÁÙÉÝXþÿÿÝ\ðøÙÉ‹•ÿÿÿÜ¥PþÿÿÝ]˜ÙÉÝTòøÙÉ‹‹•ÿÿÿðFÝTÂðÿüþÿÿ‰ÿÿÿÝØÝØ‹µlÿÿÿ¹¸º)þF‰u„‰L$$‹‰D$,‰T$(ý‰L$ ‹µÿÿÿD2ø‰D$‹E€‹0÷‹µÿÿÿ‰L$ Dþð»‰D$D2øU„‰D$³ƒ‰T$‰t$‰|$‰$èüÿÿÿÝ…Xþÿÿ‹•lÿÿÿ‹ ÿÿÿÜlÑøÝ\Ñø‹µ¼þÿÿ‹½ÿÿÿÝE˜Ý\÷øévüÿÿÞâéÚýÿÿÝ…xþÿÿ‹…lÿÿÿ‹• ÿÿÿÝ\Âø‹¼þÿÿ‹½dÿÿÿ‰lÿÿÿ9ùŒÏ‹µ¼þÿÿN‰µ¼þÿÿé-üÿÿ}¸E°‰|$} ‰D$U¨‰|$ ‰ÏÁç‰T$ 7Aø‰D$ƒé‹•ÿÿÿ‰ $tð‰t$1öèüÿÿÿÝE°1Ò‹lÿÿÿÝE¸‹…ÿÿÿÙÁÝDÈðÝDÈøÙÁØÌÙËØÉÙÌÞÉÙÉÞÌÙÊÞáÙÉÞÂÝ\ÈøÝ\Èð‹½ ÿÿÿÝE Ý\ÏðÝE¨Ý\Ïø‹…ÿÿÿ‰TÈð‰tÈô‹½dÿÿÿƒé‰lÿÿÿ9ùŒI‰¼þÿÿédûÿÿÝظ‹•|ÿÿÿ¹‰…tÿÿÿ‹E€‰L$(‹‰T$$Uè‰|$}ȉD$ ‰ÿÿÿ‰L$‰uèuЉT$‰µØþÿÿ‰t$³‰½Èþÿÿ‰|$ »‰t$‰t$‰<$èüÿÿÿ‹|ÿÿÿ¸‹U€‰D$(‰L$$‰T$ ‹…¤þÿÿ‰D$‹ÿÿÿEä‰L$‹•ÿÿÿ‰Uä‰D$‹Øþÿÿ‰L$‹•Èþÿÿ‰t$‰t$‰T$ ‰<$èüÿÿÿé²óÿÿ‹|ÿÿÿº¸‰•tÿÿÿ‹}€‰D$(ƒ‰L$$‰|$ ‹½lÿÿÿ‹µ ÿÿÿÁçT7ø‰T$‰…ÿÿÿ‰D$‹lÿÿÿEà‹•Xÿÿÿ)ʉ։• ÿÿÿFMÀ‰uàuÈ“‰D$‰Àþÿÿ‰L$‰µÌþÿÿ‰t$ ³‰t$‰t$‰•ÿÿÿ‰$èüÿÿÿ‹|ÿÿÿ¸‹U€‰D$(‰L$$‰T$ ‹…ÿÿÿLø‰L$EÜ‹•ÿÿÿ‰T$‹½ ÿÿÿ‰}܉D$‹Àþÿÿ‰L$‹•Ìþÿÿ‰t$‰t$‰T$ ‹½ÿÿÿéáþÿÿƒ½tÿÿÿtZƒ½tÿÿÿ„\‹$ÿÿÿ9pÿÿÿwöÿÿ‹}€‹7éÁðÿÿÝØÝØéñÿÿÝØ‹Xÿÿÿ1Ò1À‹½ÿÿÿ‰TÏø‰DÏüépñÿÿÝØÝØéÀøÿÿ‹•|ÿÿÿ¹‹}€‰L$(‹‰T$$‰|$ ‹½\ÿÿÿ‹µ ÿÿÿÁçD7ø‰D$‰øþÿÿ‰L$‹•\ÿÿÿMÜ‹µ`ÿÿÿ)Ö‰ð‰µôþÿÿUÈ@‰EÜuЃ‰L$‰•Ðþÿÿ‰T$‰µÜþÿÿ‰t$ ³‰t$‰t$‰…ðþÿÿ‰$èüÿÿÿ‹•|ÿÿÿ¹‹E€‰L$(‰T$$‰D$ ‹ÿÿÿTø‰T$‹½øþÿÿUà‰|$‹…ôþÿÿ‰Eà‰T$‹Ðþÿÿ‰L$‹½Üþÿÿ‰t$‰t$‰|$ ‹µðþÿÿ‰4$èüÿÿÿé¤þÿÿ‹…|ÿÿÿº‹u€‰T$(“‰D$$‰t$ ‹µ\ÿÿÿ‹½ ÿÿÿÁæL>ø‰L$‰•ìþÿÿ‰T$‹…\ÿÿÿU䋽`ÿÿÿ)ljù‰½èþÿÿEÈA‰Mä}À‹‰T$‰…Ôþÿÿ‰D$‰½Äþÿÿ‰|$ »‰|$‰|$‰äþÿÿ‰ $èüÿÿÿ‹…|ÿÿÿº‹M€‰T$(‰D$$‰L$ ‹•ÿÿÿtø‰t$Uè‹…ìþÿÿ‰D$‹èþÿÿ‰Mè‰T$‹µÔþÿÿ‰t$‹…Äþÿÿ‰|$‰|$‰D$ ‹µäþÿÿéìþÿÿesivbrfg€?@@ð?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst4.rodata.cst8.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@¹ €¨%ü+ü4ü 0 (>FS(`0‡4—4#W x  ˜çñÿ 2   FKPU Z _ dls{¹ƒ š°¸ÀÈÐ×ßdstqrb.f__g77_forceload_0.0__g77_forceload_1.1__g77_forceload_2.2.LC0.LC3.LC4.LC9.LC6.LC7xerbla_dswap_dlaset_dstqrb___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_dlamch_dlanst_dlapy2_dlartg_dlasr_dlaev2_dlascl_ k q }œ« ¹ Š t ˜¥ R |‚ ð sD | ’ Ÿ ¯ë ¹ ¦ æ ì  Õ ™ Õ ê ð  Å  m £ ³ Ã!%!M Ÿ ½ Ó!·   ' =!©!Æ  6 L!dsortc.o/ 1189291777 1000 1000 100644 2620 ` ELFœ4( U‰åWVSƒì\‹U ‹MèüÿÿÿËE‹}‰Uì‹U‰MÈ‹u‰EʼnUè‰}ä‹:º‰L$ ‰øÁè‰T$ÇÑÿ‰}܃‰D$‰4$èüÿÿÿ…À…‹uÜ…ö„î‹EÜ‹}è‹MÜ÷ЉMà‰Ë¾‹}àv¼'‹UÜ)×…ÿˆ˜‹MÄ4ý‹UÈÖ‰D$‰4$èüÿÿÿ‹EÜ‹MÄÝ]Ð4õ‹MȉT$ȉ$èüÿÿÿÝEÐÚéßàžvI‹UÈ‹EìÝúÝòÝúÝò‹MÄÝùÝñÝùÝñ‹…Ò„yÿÿÿ‹Eä‹UÜÝðÝøÙÉÝø)×…ÿÝð‰hÿÿÿÿEàÿM̉Bÿÿÿ‹}ÜÁï}ÜÑ}Ü‹uÜ…ö…ÿÿÿƒÄ\[^_]É4$¸º‰D$ ‹‰T$‰L$èüÿÿÿ…À…æ‹uÜ…ötÅ‹}Ü‹UÜ‹Mè÷׉U¼9‰}Àˆµ‹}¼‹EÜ)Ç…ÿˆ˜‹MÄ4ý‹UÈÖ‰D$‰4$èüÿÿÿ‹EÜ‹MÄÝ]°4õ‹MȉT$ȉ$èüÿÿÿÝE°ÙÉÚéßàžvG‹UÈ‹EìÝúÝòÝúÝò‹MÄÝùÝñÝùÝñ‹…Ò„wÿÿÿ‹EäÝøÝðÝøÝð‹EÜ)Ç…ÿ‰hÿÿÿÿE¼ÿMÀ‰Kÿÿÿ‹}ÜÁï}ÜÑ}Üéÿÿÿ‰4$¸º‰D$ ‹‰T$‰L$èüÿÿÿ…À…–‹uÜ…ö„¯þÿÿ‹}Ü‹Mè‹uÜ÷×9‰}¬xh‰ò‹EÜ)Â…ÒxW‹EÜ‹}È Ý×ÝÏÙÉÝáßàž†ÙÉ‹}ÈÝ×ÝÏ‹EÄ‹}ìÝÐÝÈÝÐÝÈ‹…Àt¸‹EäÝÐÝÈÝÐÝÈ‹EÜ)Â…Òy©FÿM¬y˜‹UÜÁêUÜÑ}Üéjÿÿÿ‰4$¸‹‰D$ ¿‰|$‰L$èüÿÿÿ…À…§‹uÜ…ö„íýÿÿ‹MÜ‹Uè‹uÜ÷Ñ ‰M¬x`‰ò‹}Ü)ú…ÒxO‹EÜ‹}È Ý×ÝÏÝáßàžv_‹EÈÝÐÝÈ‹}Ä‹EìÝ×ÝÏÝ×ÝÏ‹8…ÿtÀ‹}äÝ×ÝÏÝ×ÝÏ‹}Ü)ú…Òy±FÿM¬y ‹uÜÁîuÜÑ}ÜérÿÿÿfÝØÝØFÿM¬é$ÿÿÿÝØÝØFÿM¬ëÔ‰4$¸º‰D$ ‹‰T$‰L$èüÿÿÿ…À…¡‹}Ü…ÿ„ýÿÿ‹MÜ‹Uè‹uÜ÷Ñ ‰M¬xs‰ò‹EÜ)Â…Òxb‹MÄ‹EÜ‹}ÄÝÑ ÝÏÙÉÙáÙÉÙáÙÉÚéßàžv?‹}ÈÝ×ÝÏÝ×ÝÏ‹EÄ‹}ìÝÐÝÈÝÐÝÈ‹…Àt­‹EäÝÐÝÈÝÐÝÈ‹EÜ)Â…ÒyžFÿM¬ë‹‹uÜÁîuÜÑ}Üé_ÿÿÿ‰4$¹“ ‰L$¿‰|$ ‰T$èüÿÿÿ…À…Xüÿÿ‹EÜ…À„Müÿÿ‹MÜ‹Uè‹uÜ÷Ñ ‰M¬xp‰ñ‹}Ü)ù…Éx_‹EÜ‹}ÄÝÏÝ×ÙÉÙáÙÉÙáÚéßàžvA‹}ÈÝÏÝ×ÝÏÝ׋EÄ‹}ìÝÈÝÐÝÈÝЋ…Àt²‹Eä‹}ÜÝÐÝÈÙÉÝÈ)ù…ÉÝÐy¡FÿM¬ëŽ‹uÜÁîuÜÑ}ÜébÿÿÿLMSMLRSRLISI‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@® ¬ %ð+ð0ð 8ü_o##x|à  \ Mñÿ ®)?Edsortc.fdsortc___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_cmpdlapy2_  W c Ç î ƒ  ç  • ¢ N d * 7 î  dsortr.o/ 1189291777 1000 1000 100644 1824 ` ELFØ4( U‰åWVSƒì<‹u‹MèüÿÿÿËE‹} ‰u苉Mð‰E三щD$ ‹EðÁé‰}ì4 ¹‰L$“‹}‰T$Ñþ‰$èüÿÿÿ…Àu…ötg‰uà‹Uè‰ð÷ЉEÐxI‹Uàf)ò…Òx6Ý× 2ÝÏÝáßàžvCÝ׋EìÝÏ‹…ÀtÛ‹EäÝÈÝÐÙÉÝÐ)ò…ÒÝÈyÊÿEàÿMÐy·‰ñÁéÎÑþ…öu™ƒÄ<[^_]ÃÝØÝØÿEàÿMÐëݺ¹ƒ‰T$ ‹Uð‰L$‰D$‰$èüÿÿÿ…À……öt¹‰uÜ‹Mè‰ð÷ЉEÐxS‹UÜt&)ò…Òx>Ý× 2ÝÏÙÁÙáÙÁÙáÚéßàžv9Ý׋EìÝÏ‹…ÀtÓ‹EäÝÈÝÐÙÉÝÐ)ò…ÒÝÈyÂÿEÜÿMÐy­‰òÁêÖÑþëÝØÝØÿEÜÿMÐë繺ƒ‰L$ ‹Mð‰T$‰D$‰ $èüÿÿÿ…Àus…ö„ ÿÿÿ‰uØ‹Uè‰ð÷ЉEÐxO‹UØ)ò…Òx>Ý× 2ÝÏÙÉÝáßàž†ßÙÉÝ׋EìÝÏ‹…ÀtÓ‹EäÝÈÝÐÙÉÝÐ)ò…ÒÝÈyÂÿEØÿMÐy±‰ñÁéÎÑþ뺹ƒ‰T$ ‹Uð‰L$‰D$‰$èüÿÿÿ…À…qþÿÿ…ö„iþÿÿ‰uÔ‹Mè‰ð÷ЉEÐxQ‹UÔ)ò…Òx@Ý× 2ÝÏÙÁÙáÙÁÙáÙÉÚéßàžvHÝ׋EìÝÏ‹…ÀtÑ‹EäÝÈÝÐÙÉÝÐ)ò…ÒÝÈyÀÿEÔÿMÐy¯‰òÁêÖÑþë‹ÝØÝØÿEØÿMÐé@ÿÿÿÝØÝØÿEÔÿMÐëØSASMLALM‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ð ÐP %0+00088_<o<#_x¸Ð  ˆEñÿ ð)?dsortr.fdsortr___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_cmp  M ^ ñ  Ÿ ¶ = T dstatn.o/ 1189291777 1000 1000 100644 1172 ` ELF<4( èüÿÿÿÁU‹º‰åÇÇ@Ç@Ç@ Ç@‰P0‰P4‰P8‰P<‰P@‰PD‰PH‰Pt‰Pp‰Px‰Ph‰Pl]Ë $ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.gnu.linkonce.t.__i686.get_pc_thunk.cx.note.GNU-stack.comment@a | %¤+¤0¤W¨g¨#Ëpô   eñÿ  #( |òÿ0a8Odstatn.ft0.0t1.1t2.2t3.3t4.4t5.5timing_dstatn___i686.get_pc_thunk.cx_GLOBAL_OFFSET_TABLE_ dstats.o/ 1189291777 1000 1000 100644 1172 ` ELF<4( èüÿÿÿÁU‹º‰åÇÇ@Ç@Ç@ Ç@‰P‰P‰P‰P ‰P$‰P(‰P,‰Pt‰Pp‰Px‰Ph‰Pl]Ë $ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.gnu.linkonce.t.__i686.get_pc_thunk.cx.note.GNU-stack.comment@a | %¤+¤0¤W¨g¨#Ëpô   eñÿ  #( |òÿ0a8Odstats.ft0.0t1.1t2.2t3.3t4.4t5.5timing_dstats___i686.get_pc_thunk.cx_GLOBAL_OFFSET_TABLE_ dnaitr.o/ 1189291777 1000 1000 100644 9276 ` ELFd4( U‰åWVSìì‹E‹MèüÿÿÿËu‹}‰E´‹E(‰M°‹M,‰u¼‹U ‰}¬‹u ‰Eˆ‹}0‰M ‹E<‰U¸‹U$‰u¨‹u4‰½|ÿÿÿ‹} ‰E„‹M@‰U¤‹U8‰uœ‹7‰U˜‰M”‰u‹Uœ‹‰EŒ‹‹…É…´‹u¼‹…Ò„'‹»$…ÿ…I‹‹(…Ʉ볓‰µXÿÿÿ‰•`ÿÿÿ‹}¸¶1ö‰ÁùƒøŒ8‰EÀ)Á‰Â‰ÎNˆ`}Ô‰½tÿÿÿ»rë=ÝÚÙÉÙÉÚéßàžr!‹MŒBÿ¯Á1ÉЋ•|ÿÿÿljL‹UÀBN‰Â‰EÀˆ‹MŒBÿ¯Á‹|ÿÿÿÐÝDÁø‹EŒÙá¯ÂÐÝÁÙáÞÁÙîÙÉÝáßàÝÙžt?݃p‹MŒBÿÞɯÁ‹|ÿÿÿ݃hÐÝÁÙÊÝáßàÙÊžÙá‚]ÿÿÿÝÙéZÿÿÿt&z¿ÝØ‹U´¸‰D$‹M„‹‹UœÁ‹M¬‰T$ ‹U°‰D$‹…|ÿÿÿ‰D$‹‹ ‹•tÿÿÿȉEÔ‰T$‰<$èüÿÿÿ‹UÀékÿÿÿ݃€ÙÉ¿/³tÝ]àM؃Ý]؉t$‹³‰|$‰L$~‰|$ ‰D$‰4$èüÿÿÿ‰|$ ‹£º‰L$‹‹D‰T$‹EŒI‹•|ÿÿÿ¯ÈƒD<ʉ|$‰…Tÿÿÿ‰D$‰4$èüÿÿÿé öÿÿt&ÝØ‹U´EÄ¿‰|$(‰…pÿÿÿ‹»D‰D$$‰T$ ‹MO‹uˆ¯ù‹M´þ‹}¤‰D$‹•hÿÿÿ³‰L$‰T$‰u€‰t$uÀ‰|$ »»‰t$‰t$‰<$èüÿÿÿ¸‰D$(‹•pÿÿÿ‹ƒ0‰T$$‹U´‰T$ ‹M„DÁø‰D$‹…hÿÿÿ‰T$‹U¤‰D$‹M€‰T$ ‰t$‰L$‰t$‰<$èüÿÿÿéYüÿÿ“‹³0‹}¨‰T$‹M„‰T$‰|$Dñø‹u´‰D$ ‰4$èüÿÿÿ‹u¤ÙáÙúÝé²ôÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹}¸Ø« Ø@lÙXl¶édôÿÿ³Äº(»D‰t$‹³‰T$F‰…\ÿÿÿ‰|$»‰D$ ‰|$‰4$èüÿÿÿ¹)“ì‰L$‹M¤‰T$‹…\ÿÿÿ‰L$‰|$‰D$ ‰4$èüÿÿÿéòöÿÿÿF¿‰»(‹M˜‹}¼‹“4‹ƒ0lj‰AÄì[^_]˳ÿF‹u¨‹½xÿÿÿ‹‹4‰|$‹U„‰|$‰t$DÊø‹M´‰D$ ‰ $èüÿÿÿ뜋µXÿÿÿ‹»0‹M¨‰t$‹U„‰t$‰L$Dúø‹}´‰D$ ‰<$èüÿÿÿÙáÙúÝ›€éÚñÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹M¸Ø« Ø@lÙXl¶é‘ñÿÿ‹U¨ƒ‹}´‰D$‰T$‰<$èüÿÿÿ‹u¤Ýéóÿÿ‹…Xÿÿÿ‹u¨‹M´‰D$‰t$‰ $èüÿÿÿë€ÝØé,öÿÿ‹³ÿF‹u¨‰|$‹M„‰|$‹ƒ4‰t$‹}´TÁø‰T$ ‰<$èüÿÿÿ‹U˜‹‹4‹ƒ0‹u¼‰ ‰BÇéúÿÿ³ ‰4$èüÿÿÿÙƒ‹ƒ‹M¸Ø« Ø@lÙXl¶ N [ +s y ‡ ’ œ6¢ %½7Ã4Í Ø Þ ä *í ó   {8 › ¥ ± · Å3Ë Ñ4Ú ò ú3 4  %# / K W9e3‡ ²9 Î3Ô6à ë ó ü   # + 1 7 B M V _:e ,m ~ ƒ;Ž š:  © ³ ¹ Ê õ9  %$ U 9[ s ,„ « <· Õ <Û 4æ ì ö 3  @ 9I O U { œ 9² º 3À Ì  ƒ š  = % 1 -> 6Y >c r ‰ ¢ >É ô ' ?5 w ?‚ %ˆ ­ @Á É 3Ï Õ 4Þ ò ý 6 %.79 ^>q } ƒ Ÿ4± Ó9á @  #3) /48 O %bAˆA—4® Å9Î Ô í õ3û 4  ! %' L@V b o 6ÂBÍ4Ø ß H V c -{>‰ %œAdnapps.o/ 1189291777 1000 1000 100644 8912 ` ELF\4( U‰åWVSìL‹E‹} èüÿÿÿËM‹U‰…Tÿÿÿ‹u‰½Pÿÿÿ‹E‰Hÿÿÿ‹} ‰•Dÿÿÿ‹M(‰µLÿÿÿ‹U,‰…¨þÿÿ‹u$‰½@ÿÿÿ‹E0‰<ÿÿÿ‹M<‰•8ÿÿÿ‹•@ÿÿÿ‰µÐþÿÿ‹}4‰…¸þÿÿ‹u8‰¬þÿÿ‹‰½4ÿÿÿ‰µ0ÿÿÿ‰…,ÿÿÿ‹½<ÿÿÿ‹4ÿÿÿ‹ƒ‹7…À‰µ(ÿÿÿ‹‰•$ÿÿÿ…ó³‰4$èüÿÿÿ‹³‹Lÿÿÿ‹•Pÿÿÿ‹F8‹:‹•4ÿÿÿ‰… ÿÿÿ‹¹‰L$ø‹‰E¸‹…¸þÿÿ»‰T$U¸‰D$ƒ‰½€þÿÿ‰|$‰|þÿÿ‰L$ ‰•¤þÿÿ‰T$‰T$‰$èüÿÿÿ‹½Lÿÿÿ‹…À„ ÇE´1Ò»‰•ÿÿÿH‰½xþÿÿ‰…ôþÿÿˆ„ ‰µìþÿÿF»‰…üýÿÿE M´‰½ðþÿÿ}¨“‰½œþÿÿ‹½üýÿÿ³<‰…˜þÿÿ‹…ìþÿÿ‰ þÿÿ‹d‰½Hþÿÿ»e‰•èþÿÿ“„‰•Lþÿÿ‹• þÿÿ‰…@þÿÿ‹…Hþÿÿ‰µäþÿÿuœ‰Pþÿÿ‹°‰µDþÿÿ³Ü‰<þÿÿM˜‰•8þÿÿ“û‰½4þÿÿ}”‰µÈþÿÿuˆ‰…ÄþÿÿE€‰”þÿÿxÿÿÿ‰•Àþÿÿ•pÿÿÿ‰½þÿÿ½hÿÿÿ‰µ0þÿÿuȉ…,þÿÿEЉ(þÿÿ‹‰•$þÿÿ•Xÿÿÿ‰½ þÿÿ»‰µþÿÿuĉ…þÿÿ…`ÿÿÿ‰þÿÿ\ÿÿÿ‰•þÿÿ‰½ þÿÿ‰µþÿÿ‰…þÿÿ‰þÿÿƒ½ ÿÿÿ‹u´‹Hÿÿÿ‹•DÿÿÿÝDñøÝ]¨ÝDòøÝ] Ð ‹•ÿÿÿ…Ò…Ä ‹…Lÿÿÿ‹9òŽy ÝE ÙƒÙÉÙáÚéßàž†a ¾‰µÿÿÿÇE˜‹M¸‹u˜‰Ê)ò‰uœ‰ÖNˆª‹…Lþÿÿ‹Hþÿÿ‹•@þÿÿ‰…àþÿÿ‹…<þÿÿ‹½Pþÿÿ‰Üþÿÿ‰•Øþÿÿ‰…Ôþÿÿ‹4þÿÿ‰ÌþÿÿëÝÚÙÉÙÉÚéßàžƒ–BN‰EœˆZ ‹Uœ‹(ÿÿÿBÿ¯Á‹ÐþÿÿÐÝDÁø‹…(ÿÿÿÙá¯ÂÐÝÁÙáÞÁÙƒÙÉÝáßàÝÙž„y݃(‹(ÿÿÿBÿÞɯÁ‹Ðþÿÿ݃ ÐÝÁÙÊÝáßàÙÊžÙá‚hÿÿÿÝÙÙÉÚéßàž‚jÿÿÿ‹½ ÿÿÿ…ÿŽÔ‹µàþÿÿº*‹½Üþÿÿ‰T$‹xþÿÿ‹•Øþÿÿ‰t$‹…Dþÿÿ¾+‰|$ ‰L$‰$‰D$èüÿÿÿ‰t$‹½Ôþÿÿ‹8þÿÿ‹•xþÿÿ‹µØþÿÿ‰|$‹…Üþÿÿ‰L$¿‰T$‰4$‰D$ èüÿÿÿ‰|$‹uœ‹…Ìþÿÿ‹•(ÿÿÿ‹Üþÿÿ‹½Ðþÿÿ‰D$Fÿ¯Â‰L$ ‹•xþÿÿð‰T$‹µØþÿÿ ljL$‰4$èüÿÿÿ‹Uœ‰U”‹µ(ÿÿÿBÿ‹½Ðþÿÿ1ɯÆÐÇljLǃ½ ÿÿÿŽ¼¿‹•Èþÿÿ‹µ”þÿÿ‰|$‹xþÿÿ‹½ìþÿÿ‰T$‹…Äþÿÿ‰t$‰L$‰<$‰D$ èüÿÿÿº‹…Àþÿÿ‹µÄþÿÿ‰T$‹þÿÿ‹½xþÿÿ‰D$‹•ìþÿÿ‰t$ ‰L$‰|$‰$èüÿÿÿ‹U˜‹u”9òu>‹M¸~‰}˜9ÎÊ‹u˜‰Ê)ò‰uœ‰ÖN‰Výÿÿ‰M”ƒ½ ÿÿÿDÿÿÿ‹U˜‹u”9òtÂJ9ñ„õ ÝE Ùƒ‹…(ÿÿÿJÿ‹½Ðþÿÿ¯ÈÑÝÏÝDÏøÙÉÝÿÿÿÙÊÙáÙÉÚéßàž‚ë Üe¨‰÷)×Ý…ÿÿÿÙÉO‰Uœ‰½¼þÿÿÝhÿÿÿÝpÿÿÿ¶ˆIÿÿÿ‹(þÿÿ‹½0þÿÿ‹…,þÿÿ‰L$‹•$þÿÿ‹µ þÿÿ‰|$‰D$ ‰T$‰4$èüÿÿÿ‹Mœ;M˜~DÝEˆÙîÝéßàžvÙà€µÿÿÿ€€u‡€ÝUˆ‹½(ÿÿÿQþ‹µÐþÿÿ¯×Ê1ɉLÖ‹MœÝ\ÖøÇÖ‹E¸‰Æ)ÎxdÝ…xÿÿÿ‹•(ÿÿÿ‹…(ÿÿÿÝE€¯Ñ‹}œ)Âë‰ù ‹ÐþÿÿÝDÁøÝÁÙÁÙÁÙÉØÍÙÉØÌÙÊØÍÙËØÌÙÉÞÂÞêÝ\ÁøÝÁ‹(ÿÿÿÊNyÂÝØÝØ‹Mœ‹U”A9Ð~‰Ð‰Æ¿NxsÝ…xÿÿÿ‹UœÝE€‰•Tþÿÿë‹Tþÿÿ‹…(ÿÿÿQÿ¯Ð‹…ÐþÿÿúÝDÐø‹…(ÿÿÿÙÀ¯Á‹ÐþÿÿØËÙÉØÊøGÝDÁøNÙÀØÌÙÉØÍÙËÞÁÙÊÞáÝ\ÁøÝ\Ñøy©ÝØÝØ‹Mœ‹u´‰È‹U¸ð9Ð~‰Ð‰Æ¿NxvÝ…xÿÿÿ‹UœÝE€‰•Xþÿÿë t&‹Xþÿÿ‹…$ÿÿÿQÿ¯Ð‹…¸þÿÿúÝDÐø‹…$ÿÿÿÙÀ¯Á‹¸þÿÿØËÙÉØÊøGÝDÁøNÙÀØÌÙÉØÍÙËÞÁÙÊÞáÝ\ÁøÝ\Ñøy©ÝØÝØ‹Mœ‹u”~ÿ9Ï~'‹½(ÿÿÿAÿ‹•Ðþÿÿ¯ÇÈÝÂÝhÿÿÿÝDÂÝpÿÿÿÿ¼þÿÿQ‰Uœé°ýÿÿ‹µPÿÿÿ‹‹…(ÿÿÿqÿ‹½Ðþÿÿ¯ð1Ý×Úéßàž‡Â ÇEœ‰ÎNˆ“!}¼‰•ôýÿÿë‹…Pÿÿÿ‹‰|$º‹…xþÿÿ‰T$,‹•¬þÿÿ‰D$(‹…|þÿÿ‰T$$‹•xþÿÿ‰D$ ‹…$ÿÿÿ‰T$‹Uœ)ѯÁ‹¸þÿÿÁ‰D$‹@ÿÿÿ‹…¨þÿÿ‰L$‹€þÿÿ‰D$‹E¸‰L$ ‹ôýÿÿ)Ћ•Tÿÿÿ@‰ $‰E¼‰T$èüÿÿÿ‹…xþÿÿ‹Uœ‹,ÿÿÿ‰D$‹E¸)ЯÁ‹•¨þÿÿ ‰L$ ‹…xþÿÿ‹•¬þÿÿ‹Tÿÿÿ‰D$‰T$‰ $èüÿÿÿÿEœN‰ÿÿÿ‹µPÿÿÿ‹‹}¸¸‹µ@ÿÿÿ‰D$‹•¨þÿÿ)ωt$‹,ÿÿÿ‰t$‹µPÿÿÿ¯ù‰T$‹Tÿÿÿ‰t$ú“"‰L$‰$‰D$ èüÿÿÿÙƒ‹½Pÿÿÿ‹…(ÿÿÿ‹‹½Ðþÿÿrÿ¯ð 2ÝÏÚéßàž‡ ‹½$ÿÿÿJ‹µ8ÿÿÿ‹xþÿÿ¯×‹…¸þÿÿ‰t$‹u¸‰L$ Ћ•Tÿÿÿ|ñø‰|$‰$èüÿÿÿÙƒ‹…Pÿÿÿ‹(ÿÿÿ‹½Ðþÿÿ‹rÿ¯ñ 2ÝÏÚéßàž‡S ƒ½ ÿÿÿŽ!¾(‹Pÿÿÿ»$‰t$‹³‹•$ÿÿÿ‰|$~‰|$ ‹‹¸þÿÿ‰4$H¯ÂÁ‹M¸DÊø‰D$‹•xþÿÿ‰T$èüÿÿÿ‰|$ ‹•Pÿÿÿ¹%‰L$ƒL‹(ÿÿÿ‰D$‹‰4$Pÿ¯Ñ‹ÐþÿÿЋ•xþÿÿÁ‰D$‰T$èüÿÿÿ‰|$ ¹-‹•Pÿÿÿ‰L$‹xþÿÿƒt‰D$‰T$‰L$‰4$èüÿÿÿƒ½ ÿÿÿ~A‰|$º6ƒ¤‰T$‹<ÿÿÿ‹•Ðþÿÿ‰D$‹…Pÿÿÿ‰L$‰T$ ‰D$‰D$‰4$èüÿÿÿ³‰4$èüÿÿÿÙƒ‹»Ø«ØGDÙ_DÄL[^_]Ê÷ÿÿÝ؉<$‹0ÿÿÿº‰T$‹…<ÿÿÿ‹•Ðþÿÿ‰L$‹M´‰D$ ‹E¸‰T$‹•þÿÿ)È@‰T$‰EÄèüÿÿÿ‹Uœé2÷ÿÿ1ÉÿôþÿÿV‰ÿÿÿ‰U´‰êõÿÿ‹…Pÿÿÿ¾‹‰µøýÿÿ‰ÏOˆ ÙƒU¼ƒ‰•pþÿÿ‹•$ÿÿÿuĉ…tþÿÿ‹…¸þÿÿMÀ‰µ´þÿÿÁâЉ…lþÿÿ‹…(ÿÿÿ‹µÐþÿÿ‰°þÿÿÁà1ɉ\þÿÿƉµdþÿÿ‰…`þÿÿ‰•hþÿÿë1ÿ…øýÿÿ‹•(ÿÿÿ‹`þÿÿ•\þÿÿ‹…hþÿÿdþÿÿ…lþÿÿOˆ ‹\þÿÿ‹µøýÿÿ‹•ÐþÿÿñÝÊÙÉÝáßàÝÙžv­ÝØ‹…<ÿÿÿ‹µÐþÿÿ‰D$ ΋E¸‰T$‹øýÿÿ‹µtþÿÿ‹•´þÿÿ)È@‰$‰t$‰EÄèüÿÿÿ‰t$‹…xþÿÿ‹U¸‹dþÿÿ‰D$ ‹…øýÿÿ‰L$ƒÀ9Ð~‰Ð‰EÀ‹•°þÿÿ‰$èüÿÿÿ‹xþÿÿ‹…lþÿÿ‹µtþÿÿ‰L$ ‹•Lÿÿÿ‰D$‹…øýÿÿ‰t$‹ ‹U¸È@9Ð~‰Ð‰E¼‹µpþÿÿ‰4$èüÿÿÿÙîéâþÿÿ9ò…¢ôÿÿÝE ÙƒÙÉÙáÚéßàž†Šôÿÿ‹½Pÿÿÿÿ‹u´ÿôþÿÿVéþÿÿ¿‹µüýÿÿ‹ þÿÿ‰|$‹•xþÿÿ‹½ìþÿÿ‰t$ ‹…ðþÿÿ‰L$‰T$‰<$‰D$èüÿÿÿ‹µèþÿÿ¸#‹üýÿÿ‰D$‹•œþÿÿ‹½xþÿÿ‰t$‹…ìþÿÿ¾(‰L$ ‰T$‰|$‰$èüÿÿÿ‰t$‹äþÿÿ‹µìþÿÿ‹•üýÿÿ‹½˜þÿÿ‰L$‹…xþÿÿ‰4$‰T$ ‰|$‰D$èüÿÿÿ‹u´ékóÿÿ‹Ú¾ ¿ ‰ $‰t$³æèüÿÿÿÙƒ“ƒ0‰T$ØñÙɉ$Ý›0Ý›èüÿÿÿ‰|$‰4$èüÿÿÿ‹Tÿÿÿ1ÒÝ“(‰“ÛÞñÜ‹0Ý› éˆðÿÿ‹M¸éæõÿÿÝE ÙƒÙÁÙáÝéßàž†üõÿÿÝØÝØ‹M¸~‰}˜9ÎŒ¦õÿÿékþÿÿ‹(ÿÿÿ‹½˜þÿÿ‹µœþÿÿ¯ÊÑ‹•ÐþÿÿÝDÊøÝÿÿÿÝÊÝÿÿÿÝDÊÙɉ|$‰4$ÝØýÿÿÝøþÿÿÝE¨ØÀÝ]€èüÿÿÿÝ…ØýÿÿÙÉØÈ‹u”‹E˜ÙÁ‰ñÝE€)Á‰Ï‰EœOÜéÙÉØËÙËÜ…ÿÿÿÙËÞÂÞêܵÿÿÿÜ…ÿÿÿÝ…øþÿÿÙÊÝ]ÐÝ]ÈÝ]؈ãôÿÿMÄ•`ÿÿÿ‰„þÿÿ…\ÿÿÿ‰•ˆþÿÿ‰…Œþÿÿ‹Uœ)ÖF‰…\ÿÿÿƒø~ ¾‰µ\ÿÿÿ‹ˆþÿÿ‹•þÿÿ‹µxþÿÿ‰L$‹…þÿÿ‹Œþÿÿ‰T$‰t$ ‰D$‰ $èüÿÿÿ‹Uœ;U˜~CÝEÈ1ö‹(ÿÿÿBþ¯Á ‹…ÐþÿÿÝ\ÈøÇȉtÈ‹E”H9Ð~‹µÐþÿÿ1À‰DÎ1À‰DÎ ÇEÈ‹…<ÿÿÿ¹‰L$$‹(ÿÿÿ‹µ0ÿÿÿ‰D$Bÿ¯Á‰t$ ‹µÐþÿÿÇEÌð?Æ‹µˆþÿÿLÐø‹…xþÿÿ‰L$‹þÿÿ‰t$‹u¸‰D$‹…„þÿÿ)Ö‰L$ ‹•þÿÿF‰uÄ‹Œþÿÿ‰D$‰$‰L$èüÿÿÿ‹Mœ‹U”q‰µXÿÿÿ9Ö~‰•Xÿÿÿ‹µ<ÿÿÿ¸‹•0ÿÿÿ‰D$$‹…(ÿÿÿ‰t$qÿ¯ð‰T$ ‹•Ðþÿÿ‹…ˆþÿÿ ò‹µxþÿÿ‰L$‹•Œþÿÿ‰D$‹þÿÿ‹…þÿÿ‰t$‹µ þÿÿ‰L$ ‰T$‰4$‰D$èüÿÿÿ‹•0ÿÿÿ¹‹µ$ÿÿÿ‰L$$‹…4ÿÿÿ‹¸þÿÿ‰T$ ‹Uœ‰D$J¯Ö‹µþÿÿÑ‹•xþÿÿ‰D$‹þÿÿ‹…þÿÿ‰µˆþÿÿ‰t$‹µ¤þÿÿ‰T$‹• þÿÿ‰t$‰D$ ‰$‰Œþÿÿ‰L$èüÿÿÿ‹u”‹UœFÿ9Ð~6‹(ÿÿÿBÿ¯Á ‹…ÐþÿÿÝÈÝ]ÈÝDÈFþ9ÐÝ]Ð~ ‹…ÐþÿÿÝDÈÝ]ØJO‰Mœ‰nýÿÿ‹M¸~‰}˜9ÎŒ0òÿÿéõúÿÿ‹½Pÿÿÿ‹ÇEœ‰ÎNˆ õÿÿ»dë;ÝØ‹…ÐþÿÿÝÈÙÉÚéßàžr‹(ÿÿÿBÿ¯ÁЋ•ÐþÿÿÝ‹UœBN‰EœˆÀôÿÿ‹Uœ‹(ÿÿÿBÿ¯Á‹ÐþÿÿÐÝDÁø‹…(ÿÿÿÙá¯ÂÐÝÁÙáÞÁÝáßàžt/Ü‹(‹(ÿÿÿBÿ݃ ÙɯÁ Ýáßàž‚gÿÿÿÝÙébÿÿÿzÏÝØÝ؉<$‹•0ÿÿÿ¸‰D$‹<ÿÿÿ‹…Ðþÿÿ‰T$‹•Pÿÿÿ‰L$ ‰D$‰T$èüÿÿÿ‹UœÙîÙÉ뉋…xþÿÿ¿‹µTÿÿÿ‰|$,‹•¬þÿÿ‰D$(‹>‹µ|þÿÿú‹•¸þÿÿ‰D$$‹…$ÿÿÿ‰t$ ‹½xþÿÿ¯Á‰|$‹@ÿÿÿ‹½¨þÿÿ‰L$4‹…€þÿÿ‰t$‹•Tÿÿÿ‹!‰|$‹µ¤þÿÿ‰ $‰D$ ‰t$‰T$èüÿÿÿ‹½Pÿÿÿ‹éŸóÿÿ‹½,ÿÿÿ‹µxþÿÿ‹…8ÿÿÿ¯×‹½Ðþÿÿ‰t$‰t$ ‹µ¨þÿÿ‰D$Ö‹•Tÿÿÿ‰D$ωD$‰$èüÿÿÿé_õÿÿ‹…,ÿÿÿ‹µ¨þÿÿ‹½xþÿÿ¯Â‹¬þÿÿ‰|$‰|$ƉT$ ‹•Tÿÿÿ‹‰$4Á‰t$èüÿÿÿ‹½Pÿÿÿ‹é ôÿÿÙƒéºýÿÿAll_napps: shift number._napps: The real part of the shift _napps: The imaginary part of the shift 1_napps: off diagonal element._napps: matrix splitting at row/column no._napps: matrix splitting with shift number._napps: Start of current block _napps: End of current block LeftRightNA_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}_napps: betak = e_{kev+1}^T*H*e_{kev}_napps: Order of the final Hessenberg matrix _napps: updated Hessenberg matrix H for next iterationsafe minimumprecision€?ð?ð¿‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.rodata.cst8.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@C àð %„+ˆ80ˆï8x EˆR y¤‰¤#Ç’Œ   ¬2ñÿ  #(07 @(F0 NSX]ci nCv£« `òÿ²ºÁÈÐ×Þæíô |òÿü $+dnapps.ft0.0t1.1t2.2t3.3t4.4t5.5first.6ovfl.7smlnum.8ulp.9unfl.10.LC4.LC3.LC7.LC10.LC19.LC1dnapps___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_dlaset_ivout_dvout_dlartg_dgemv_dcopy_dlacpy_dscal_dmout_timing_dlanhs_dlamch_dlabad_dlapy2_dlarfg_dlarf_daxpy_ ± Ï ×Ý   - W!v ž ¹ Ë ã ï û ( 4 I ¦ ¾ N  1 K Â""O#Â""] ø$M ï %9 &“ £ '©  ( c m  ª #à ö # ) "A s )y  ‡  *“ ñ +5 > 3(n(·(Ï 6"z#´# ٠Þ,ä ê ð    -,& , 6 < R Ò./y00‹0 ˆ — ð+m ‹%á1'&: dnaup2.o/ 1189291777 1000 1000 100644 11412 ` ELF¨4( U‰åWVSì‹u‹U èüÿÿÿËM‹E‰uÌ‹}‰UÈ‹u‰MÄ‹U ‰EÀ‹M$‰}¼‹E(‰u¸‹}0‰U´‹u4‰M°‹U8‰E¬‹M<‰}¨‹E@‰u¤‹}D‰U ‰Mœ‰E˜‰}”‹uH‹MP‹ET‹UL‰µtÿÿÿ‹u\‰xÿÿÿ‹Md‰E‹}X‰•pÿÿÿ‹Ẻµ|ÿÿÿ‹U`‰`ÿÿÿ‹uh‰}Œ‹8‰Uˆ‰u„…ÿ„…À… ‹³$»P…ö„›‹E„º¹‰“$‹Uˆ‰L$<‹M”‰D$8‹µ`ÿÿÿ‰T$0‹E˜‰L$,‹U ‰|$‹M°‰t$4‹uœ‰D$(‹E¬‰t$$‹u¸‰T$ ‹U¼‰L$‹MĉD$‹Eȉt$‹ủT$ ‰L$‰D$‰4$èüÿÿÿ‹Ũ:c„.Ä[^_]Ãv‹ƒ(…À„â‹U¨‹1ö…À‰³(„¶ƒ»4Ï‹½`ÿÿÿ‹uŒ‹U‰|$4‹E°‹|ÿÿÿ‰t$,‹}”‹uœ‰L$0‹M˜‰T$(‹U ‰L$‹M¸‰t$‹u¼‰T$‰D$$‰|$ ‹…pÿÿÿ‰D$‹½tÿÿÿ‰t$‹uĉ|$ ‰L$‰4$èüÿÿÿºƒ‰“‰$èüÿÿÿ‹}ȶ‰“D1Ò‰‹81ɉƒ,1À…ÿ‰“$‰‹(‰ƒt:Ǻ‰“ éWüÿÿt&‹‹…É„9‹UȶéÈýÿÿ´&1ö‰³ é&üÿÿv‹M„‹…ÀŽÜÇñØÿÿ‹U¸‹³,‹}¤‰‰7‹U̳Çc‰4$èüÿÿÿÙƒ‹ƒØ«ÙX4Ä[^_]ó@º7‹‰t$‹³‰T$F‰…$ÿÿÿ‰L$‰D$ ‰|$‰4$èüÿÿÿº,ƒx‰T$‹U”‰D$‹$ÿÿÿ‰4$‹E˜‰T$‰L$‹M¼‰D$ ‰L$‰L$èüÿÿÿ‹“4éÿüÿÿ³¤‹U¸¿&‰t$‹³ƒ‰|$~‰T$‰|$ ‰D$‰4$èüÿÿÿ‰|$ “̹‰L$‹M¸‰T$‹…tÿÿÿ‰L$‰4$‰D$èüÿÿÿ‰|$ º$ƒì‰T$‹U¸‰D$‹pÿÿÿ‰T$‰4$‰L$èüÿÿÿ‹E¨ƒ8…Œûÿÿ‰|$ ¹$“‰L$‹M¸‰T$‹…xÿÿÿ‰L$‰4$‰D$èüÿÿÿéWûÿÿ³‹E¸‰t$‹tÿÿÿ‰t$‰L$ ‹•|ÿÿÿ‰$‰T$èüÿÿÿ‰t$‹½pÿÿÿ‰t$‰|$ ‹}¸‹|ÿÿÿ‹‰<$щD$èüÿÿÿéìúÿÿ‹U„¸‹Mˆ‰D$<‹E”‰T$8‹µ`ÿÿÿ‰L$0‹U˜‰D$,‹E°‰|$‹M ‰t$4‹uœ‰T$(‹U¬‰t$$‹u¼‰D$‹EĉT$‹Uȉt$‹ủL$ ‹‰L$ ‰D$‰T$‰4$èüÿÿÿƒ>c…9úÿÿ‹U„‹…ÀŽ.þÿÿÇñØÿÿ‹u¸‹‹,‹}¤‰‰ébýÿÿ‹}Ì1Ò‰“ÇéZùÿÿ‹ ‰ $èüÿÿÿÙƒ‹»‹uÈØ« ØGlÙ_l¶‹`ÿÿÿ‰T$‰D$4ù‹}ĉt$ ‰<$èüÿÿÿ‹MÄ‹Uˆ‹EÌ‹1ÇBÇF‰2éùÿÿ‹‹}°‹uĉL$‹…`ÿÿÿ‰L$‰|$‰D$ ‰4$èüÿÿÿéõûÿÿ1Àƒ»4‰ƒ$xUÔ‹MŒ‹E‰T$(‹µ|ÿÿÿ‰D$‹E”‰t$$‰L$ ‹•xÿÿÿ‰T$‹µpÿÿÿ‹U˜‰t$‹tÿÿÿ³0‰D$ ‰T$‰L$‰µPÿÿÿ‰<$‰t$èüÿÿÿ‹}Ô…ÿtI‹}„Çøÿÿÿé±ûÿÿ‰|$¹,ƒ4‰L$‹‹³‰D$Q‰T$ ‰t$‰ $èüÿÿÿéMÿÿÿ³‰µLÿÿÿ‹‹0‰t$‹½|ÿÿÿ¯ÉωD$ ‹•Lÿÿÿ‰T$‹µtÿÿÿ‰t$‹½Pÿÿÿ‰<$èüÿÿÿ‹ƒ0‹Lÿÿÿ‰Æ‰L$¯ð‹•|ÿÿÿÆ<ò‰|$ ‹½Lÿÿÿ‰|$‹pÿÿÿ‰L$‹…Pÿÿÿ‰$èüÿÿÿ‰|$‹³0‹|ÿÿÿ‰|$‰ò¯ÖrÁ‰T$ ‹µxÿÿÿ‰t$‹Pÿÿÿ¾‰ $èüÿÿÿ‹“@‹‹D‹E¼‰“H‹}¸‰‰‰t$$‹½|ÿÿÿωD$ ‹E¸‰|$‹•xÿÿÿ‹}¼‰T$‹µpÿÿÿ‹UÀ‰t$‹tÿÿÿ‰T$‹u¨‰D$ ‰L$‰|$‰4$èüÿÿÿ‹M¼‹ƒ@‹@9„ú‹µLÿÿÿ‹M¸‰t$‹‹½|ÿÿÿ‰t$‰Ð‹u¼Áàø»8‰D$ ‹xÿÿÿ‰4$щD$èüÿÿÿ‰½\ÿÿÿ‹U´‹M¸‰|$‰T$‹‹…|ÿÿÿ‰ÖÁæƉt$ Á⋽pÿÿÿ :‰L$‹…tÿÿÿ‰T$‹U¼‰$èüÿÿÿƒ»4L‹U¸‹ ‰ÊJx0Ùƒ‰Ö‹½xÿÿÿÝÝéßàžuz‹E¸‰ñvÿ‰‹E¼ÿƒÇJyàÝØ‹“8;“H}‹u¤‹»,9>|…É…+ ƒ»4[݃Pº¿‹E˜‹`‹uÀÝX‰T$‰|$ ‰lÿÿÿ‰L$‰4$èüÿÿÿ…À“bMÒ‰•Xÿÿÿ‰Hÿÿÿ„â‹MÀº¿‰|$ ³d‰T$‰ $‰t$èüÿÿÿ…À‹f‰Tÿÿÿ„~¸¿‹MÀ‰D$ ‰|$‹•Tÿÿÿ‰ $‰T$èüÿÿÿ…À„&º¿‹EÀ‰|$ ‰T$‹Xÿÿÿ‰hÿÿÿ‰L$‰$èüÿÿÿ…À„ƒ‹EÀ‹hº‰T$¿‰|$ ‰dÿÿÿ‰L$‰$èüÿÿÿ…À„%‹EÀ¿¹‰|$»j‰L$ ‰|$‰$èüÿÿÿ…À„ǹ‰L$‹…xÿÿÿ‰D$‹•pÿÿÿ‰T$‹tÿÿÿ‰L$ ‹…Pÿÿÿ‰D$‹•Lÿÿÿ‰T$‹Hÿÿÿ‰ $èüÿÿÿ¸º‰D$ ‹EÀ‰T$‹lÿÿÿ‰$‰L$èüÿÿÿ…À„&‰t$‹uÀ¸‰D$ º‰T$‰4$èüÿÿÿ…À„θº‹MÀ‰D$ ‰T$‹µTÿÿÿ‰ $‰t$èüÿÿÿ…À„p¸º‹MÀ‰D$ ‰T$‹µXÿÿÿ‰ $‰t$èüÿÿÿ…À„¸º‹MÀ‰D$ ‰T$‹µdÿÿÿ‰ $‰t$èüÿÿÿ…À„º‰|$‹}À¹‰L$ ¸‰D$‰<$èüÿÿÿ…À„º‰T$‹µxÿÿÿ‰t$‹pÿÿÿ‰L$‹…tÿÿÿ‰D$ ‹½Pÿÿÿ‰|$‹•Lÿÿÿ‰T$‹µHÿÿÿ‰4$èüÿÿÿ‹‹HI‰0ÿÿÿxZ‹½tÿÿÿ‹µxÿÿÿ‰½@ÿÿÿ‹½pÿÿÿëÝØÜ>ƒÇ݃ƃ…@ÿÿÿÿ0ÿÿÿx%‰|$‹@ÿÿÿ‰ $èüÿÿÿ݃XÙÉÝáßàžrÄÝÙ뺾¿‰T$ ‰t$‹Tÿÿÿ‰L$‹…Hÿÿÿ‰$èüÿÿÿ‰|$ƒH‹•pÿÿÿ‰T$‹µtÿÿÿUÒ‰t$‹xÿÿÿ‰D$‰L$ ‹½Lÿÿÿ‰$‰|$èüÿÿÿ‹³HN‰µ,ÿÿÿxZ‹½tÿÿÿ‹µxÿÿÿ‰½Dÿÿÿ‹½pÿÿÿëÝØ܃Ç݃ƃ…Dÿÿÿÿ,ÿÿÿx%‰|$‹Dÿÿÿ‰ $èüÿÿÿ݃XÙÉÝáßàžrÄÝÙ뺉T$‹µxÿÿÿ‰t$‹pÿÿÿ‹uÀ‰L$‹…tÿÿÿ‰D$ ‹½\ÿÿÿ‰|$‹•Lÿÿÿ‰4$‰T$èüÿÿÿƒ»4p‹M¤‹“,9}9‹‹8‹ƒH9Á} ‹}„Ç‹}¸‹7…öu 9Á} ‹u„Ç‹}¸‰é)óÿÿ‹ƒH‹‹8ëÒ‹M¼‹u¸‹“H‹9‹‹8‰}Ø‹³l‰Uà¿"U؉E܉M䋉t$‹³‰|$¿)F‰…8ÿÿÿ‰T$‰L$‰D$ ‰4$èüÿÿÿ‰|$ƒ‰D$‹•8ÿÿÿ‰T$ ‹tÿÿÿ‰L$‹½Pÿÿÿ‰4$‰|$èüÿÿÿ“¼¸.‰T$‰D$‹8ÿÿÿ‰L$ ‹½pÿÿÿ‰|$‹…Pÿÿÿ‰4$‰D$èüÿÿÿº5‹ì‰T$‰L$‹½8ÿÿÿ‰|$ ‹…xÿÿÿ‰D$‹•Pÿÿÿ‰4$‰T$èüÿÿÿé£ùÿÿ‰“Héûøÿÿ³$¸+‰t$‹³‰D$~‰½(ÿÿÿ‰|$ ‹•tÿÿÿ»P‰T$‹Pÿÿÿ‰4$‰L$èüÿÿÿ‰|$¸0¿‰D$‹•(ÿÿÿ‰T$ ‹pÿÿÿ‰L$‹…Pÿÿÿ‰4$‰D$èüÿÿÿ‰|$“€‰T$‹(ÿÿÿ‰L$ ‹…xÿÿÿ‰D$‹½Pÿÿÿ‰4$‰|$èüÿÿÿé×ýÿÿ¸¿‰D$ ‰|$‹•dÿÿÿ‰T$‹µHÿÿÿ‰4$èüÿÿÿéÊûÿÿ‰t$¿º‰|$ ‰T$‹Hÿÿÿ‰ $èüÿÿÿé±ùÿÿ‰L$¸¿‰D$ ‰|$‹…Hÿÿÿ‰$èüÿÿÿéYùÿÿ‰T$¾¸‰t$ ‰D$‰ $èüÿÿÿéûøÿÿ» ¸0‰|$‹»‰D$W‰•4ÿÿÿ‹³0‰T$ ‹|ÿÿÿ¯öñ³Ð‰D$‹•Pÿÿÿ‰<$‰T$èüÿÿÿ‰t$‹“0¹0‰L$‹…4ÿÿÿ‰Ö¯ò‰D$ ‹|ÿÿÿÖñ³‰D$‹•Pÿÿÿ‰<$‰T$èüÿÿÿ‰t$¹*‰L$‹‹0‹…4ÿÿÿ‰Ê¯Ñ‰D$ ‹µ|ÿÿÿJƉT$‹Pÿÿÿ‰<$‰L$èüÿÿÿé¿÷ÿÿ‰|$º¾‰T$ ‰t$‹Hÿÿÿ‰ $èüÿÿÿéúÿÿ¸º‰D$ ‰T$‹µTÿÿÿ‰t$‹Hÿÿÿ‰ $èüÿÿÿé¿ùÿÿ¸º‰D$ ‰T$‹µhÿÿÿ‰t$‹Hÿÿÿ‰ $èüÿÿÿéaùÿÿ¸º‰D$ ‰T$‹µlÿÿÿ‰t$‹Hÿÿÿ‰ $èüÿÿÿéùÿÿ‰t$¹¸‰L$ ‰D$‹•Hÿÿÿ‰$èüÿÿÿé±øÿÿº¹‰T$ ‰L$‹…lÿÿÿ‰D$‹•Hÿÿÿ‰$èüÿÿÿé øÿÿ‰t$º¹‰T$ ‰L$‹…Hÿÿÿ‰$èüÿÿÿé²÷ÿÿ¿º‰|$ ‰T$‹lÿÿÿ‰L$‹…Hÿÿÿ‰$èüÿÿÿéN÷ÿÿ³,¸7‰t$‹³‰D$ƒV‰•<ÿÿÿ‰T$ ‰L$‰E€‰D$‰4$èüÿÿÿ‹dº+‰T$‹U¸‰L$‹…<ÿÿÿ‰T$‰D$ ‹M€‰4$‰L$èüÿÿÿé íÿÿ‹E¨ƒ8„e‹“4…ÒŽ1¾4»‰t$‹³‰|$~‰|$ ‹…\ÿÿÿ‰D$‹Lÿÿÿ‰4$‰L$èüÿÿÿƒ»4Žè‹E¼‹M¸‹‰UØ‹º‹Ä‰EÜE؉T$“‰L$‰|$ ‰T$‰D$‰4$èüÿÿÿ‰|$ ‹U¸¹)‰L$ƒÜ‰D$‹‹tÿÿÿ‰4$‹U¼Á‰T$‰D$èüÿÿÿ‰|$ ‹U¸¹)‰L$ƒ‰D$‹‹pÿÿÿ‰4$‹U¼Á‰T$‰D$èüÿÿÿ‰|$ ‹U¸¹.‰L$ƒ4‰D$‹:‹xÿÿÿ‰4$‹U¼ù‰D$‰T$èüÿÿÿ‹u¨‹…À…xêÿÿ‹}̹‰‹(Çé>êÿÿ‹E¼‰ÏÁï‹09Ñø‰³<9Ð~‰Ðƒø„…‹U¼‰‹“0‹M¼‹ƒø„Œ‹M¸)Â9ð‰ŽLþÿÿ¾‰t$$‹|ÿÿÿщD$ ‹U¼‹E¸‰L$‹½xÿÿÿ‰|$‹µpÿÿÿ‹}À‰t$‹tÿÿÿ‰D$ ‹u¨‰T$‰L$‰|$‰4$èüÿÿÿéïýÿÿ‹“0ƒú~.‰×‹M¼Áï:Ñø‰éuÿÿÿƒúŽkÿÿÿǸé[ÿÿÿ‹E¼Çé?ÿÿÿ_naup2: **** Start of major iteration number ****Epsilon-Machine_naup2: B-norm of residual for compressed factorization_naup2: Compressed upper Hessenberg matrix H_naup2: The number of shifts to apply _naup2: Real part of the shifts_naup2: Imaginary part of the shifts_naup2: Ritz estimates of the shifts_naup2: Corresponding B-norm of the residualLMSRSMLRLISI_naup2: NEV, NP, NUMCNV, NCONV are_naup2: Real part of the eigenvalues of H_naup2: Imaginary part of the eigenvalues of H_naup2: Ritz estimates of the current NCV Ritz values_naup2: Sorted real part of the eigenvalues_naup2: Sorted imaginary part of the eigenvalues_naup2: Sorted ritz estimates._naup2: Real part of the eig computed by _neigh:_naup2: Imag part of the eig computed by _neigh:_naup2: Ritz eistmates computed by _neigh:_naup2: The length of the current Arnoldi factorization_naup2: Extend the Arnoldi factorization by_naup2: no. of "converged" Ritz values at this iter._naup2: NEV and NP are_naup2: "wanted" Ritz values -- real part_naup2: "wanted" Ritz values -- imag part_naup2: Ritz estimates of the "wanted" values UUUUUUå?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst8.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@' T%@ %h+h`0hb8ÐEØRìyð‰ð#’Øà & ¸#›ñÿ  #(08 @$I(S,[0e4o8x<‚@ŠD‘H›P¤X ­²·¼Á Ç Í'Õì  `òÿ!(08< |òÿDKRY_fnv~„Œ”dnaup2.ft0.0t1.1t2.2t3.3t4.4t5.5cnorm.6getv0.7initv.8update.9ushift.10iter.11kplusp.12msglvl.13nconv.14nevbef.15nev0.16np0.17numcnv.18rnorm.19eps23.20.LC2.LC3.LC1.LC4.LC10.LC28dnaup2___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_dnaitr_dnapps_arscnd_debug_ivout_dgetv0_dlamch_powtiming_dvout_dmout_dcopy_ddot_dnrm2_dneigh_dngets_dnconv_s_cmpdsortc_dlapy2_s_copy' (Å Ó Ù ô b)‚ ™ ¥ *) / 7+c k q € Š • Ÿ,© À-Æ Ï û ' ; ^.p v ’ ˜ ³ ¼ Á+Ç,Ü á/ç !õ0   " * 2 : D J P c r ” ¸ È Ö+Ü â1è ü  ,22= p3v  “,™ ´-¾ ä2ó 2/ P2[ ‚4®4 ",)Q h y +‡ 1– ­ Ñ5Û é ü61  64\ €4 ” Û ù7 ' ,- D 2O [ ‘ 4— × 4á  4 # , † 8 à Ü 4* 90 G w } ˆ š § º Ú :â   :& Y :Ž :Ÿ à :â ò :C ;j :“ : :ñ : :I:š;  ð<ö 2=< s;y É<Ï ";( 8 B H {   — ¢ ¹ #Ã,é-ó 2# V2a 2š ¥ ´,Ñ ç22) S2‚=«=Ô=÷= ,$ : P2Z ƒ ™2¬ Ý2=5=d=“=¼=ë==C=N ],g ‡- º-Ñ ä î,- : J $b-x š2° Ò2è  2% E b ×8â dnaupd.o/ 1189291777 1000 1000 100644 7088 ` ELFØ4( U‰åWVS켋M ‹UèüÿÿÿËu‹E‰Mì‹M$‰Uð‹}‰uà‹u<‰Eè‹E0‰MØ‹Mð‰}ä‹U‰uÈ‹}4‰EÔ‹‰UÜ‹UD…À‰}ЉUÌ„Q‹ƒ\‰E¸‹“X‰U´‹»‹³ ‹‹,º¸‰T$h‹ỦD$d‹E8‰T$`‹UЉD$\‰T$X‹UÈDÊø‰D$Tƒ4Lòø‰D$PDúø‰D$H‰L$L‹M´|Êø‰|$D‹»‹u¸‹0‰L$O‰½PÿÿÿˆìUØ}ȉ•xÿÿÿ‹U‰½pÿÿÿ‹}€uЉµtÿÿÿMà‹uœ‰|ÿÿÿÁâ‰ù‰•XÿÿÿEÀщ…lÿÿÿ‰\ÿÿÿë,‹EŒ…À„ÇEŒ‹…XÿÿÿƒÆ…\ÿÿÿÇÿPÿÿÿxuÝÙîÙÉÙáÙÉÚéßàžrĉ|$‹hÿÿÿƒÆ‹U¬‰L$‰$èüÿÿÿØ»‰|$‹…hÿÿÿ‹|ÿÿÿ‹U¬‰D$ ‰L$‰$Ý]àèüÿÿÿ‹…Xÿÿÿ…\ÿÿÿÇÿPÿÿÿy‘¶‹µhÿÿÿ¸“‰D$,‹M„‹}˜‰t$(‹E”‰L$$‹M€‰t$‹u¬‰T$ “‰|$»‰D$‰L$‰T$ ‰t$‰t$‰<$èüÿÿÿƒ}ˆr‹U¬1ɉ4ÿÿÿ‹2N‰µLÿÿÿˆ«‹}„‹u˜‰½dÿÿÿƒÇ‹…dÿÿÿ‰½`ÿÿÿ~‹uœ‰…TÿÿÿëF¬S¸`ȇ̗Ì#ï  p € æñÿ  #(   <AF K  PWL_ vŒ” `òÿ›£«³ºÁÈ |òÿÐØßdneigh.ft0.0t1.1t2.2t3.3t4.4t5.5__g77_forceload_0.6.LC2.LC7.LC8.LC9dcopy_dneigh___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_dlacpy_dlaqrb_dtrevc_dnrm2_dscal_dgemv_timing_dlapy2_dmout_dvout_ Z ek¤ ¸Ý ÿI u T Z €!­ Ö à ü"Û ãé ï#õ + G b$r ”!Æ!Û % B&d$† ®&¹ Ëé& &# C&dngets.o/ 1189291777 1000 1000 100644 3476 ` ELF4( U‰åWVSƒì\‹U‹EèüÿÿÿË}‹M‰UØ‹U ‰EÔƒ‹u ‰}ЉM̉Uȉ$èüÿÿÿ‹»º¸‹O<»‰T$ ‰MĉD$‰|$‰4$èüÿÿÿ…À……‹UÈ¿‹M̉|$‹EЋ}Ô‰T$‹U؉L$‰D$ ‹}ð‹ ‰|$È‹‰Eðƒ‰M¼‰L$‰$èüÿÿÿ}Ü‹Mȸ‹ỦD$‹EЉL$‹MÔ‰T$‹U؉D$ ‹‹ ‰|$‹U¼‰4$ȉE܉T$èüÿÿÿÙƒ‹}Ô‹uЋÝDÎøÜ,ÎÝéßàžuwzu‹uÌÝDÎøÜÎÚéßàžufzdAÿ‹}Ø‹M‹UÔÿƒ9‰uW¶¼'‹uÌ¿‹MЉ|$‹EÈ‹UÔ‰t$‹}¼³‰L$‰D$ ‰T$‰|$‰4$èüÿÿÿët&ÝØ‹Mƒ9t¶‹‰ $èüÿÿÿÙƒ‹ƒØ«Ø@@ÙX@‹UÄ…ÒŽ»‹Mؾ‰|$‹»‹U¼‰t$w‰t$ ‰L$‰T$‰<$èüÿÿÿ‰t$ ¸ ‹UÔ‰D$‹E¼‹‰L$‰T$‰D$‰<$èüÿÿÿ‰t$ ‹Eй4‰L$“$‹MÔ‰T$‹U؉D$‹‹ ‰<$ȉEàEà‰D$èüÿÿÿ‰t$ ‹E̹4‰L$“X‹MÔ‰T$‹U؉D$‹‹ ‰<$ȉEäEä‰D$èüÿÿÿ‰t$ º8‹EȉT$‹uÔ‹Œ‰L$‹U؉D$‹‹ ‰<$uè‰t$ȉEèèüÿÿÿƒÄ\[^_]ö‰4$ƒÄº‰T$ ¹‰L$‰EÀ‰D$èüÿÿÿ…ÀuL‹Uȸ‹M̉D$‹}ЋEÔ‰T$‹U؉L$‰|$ ‹8Eì‹ ‰D$ƒω}컉}¼‰|$éKýÿÿ‰4$¸º‰D$ ‹‰T$‰L$èüÿÿÿ…À„}‰4$¸¹‰D$ “‰L$‰T$èüÿÿÿ…À…‹Uȹ‹}̉L$‹EЋMÔ‰T$‹U؉|$‰D$ ‹:“‹Mä‰L$ø‹}À‰Eät&‰U¼‰T$‰<$é¦üÿÿ‹Mȸ‹ỦD$‹EЉL$‹MÔ‰T$‹U؉D$ ‹‹ ȉEèEè‰D$“ë´‰4$¹º‰L$ ƒÆ‰T$‰D$èüÿÿÿ…À„ƒ‰4$º¸‰T$ ‹È»‰D$‰L$èüÿÿÿ‰}¼…À}Ü… üÿÿ‹Mȸ‹ỦD$‹EЉL$‹MÔ‰T$‹U؉D$ ‹‹ ‰|$È‹MÀ‰E܃‰D$‰ $èüÿÿÿéÂûÿÿ‹Mȸ‹ỦD$‹EЉL$‹MÔ‰T$‹U؉D$ ‹‹ ȉEàEàéÿÿÿLMLRSR_ngets: KEV is_ngets: NP is_ngets: Eigenvalues of current H matrix -- real part_ngets: Eigenvalues of current H matrix -- imag part_ngets: Ritz estimates of the current KEV+NP Ritz valuesSMLISI‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@@  x %€+€4€0 Œ  >„ÊFPSXz\Š\#“l ð \ µñÿ  #(  <A FM@U l‚Š `òÿ‘—Ÿ |òÿ§®dngets.ft0.0t1.1t2.2t3.3t4.4t5.5__g77_forceload_0.6.LC1.LC7dcopy_dngets___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_s_cmpdsortc_timing_ivout_dvout_ + ?EX o® · Æ  ~ –¬ ´º ÀÆ Ý ï & :P vŒ ²Ë î #\ g Š —¶ Ã÷ V o |› ¡ ®ö dsaitr.o/ 1189291777 1000 1000 100644 9244 ` ELF 4( U‰åWVSìÜ‹U‹}èüÿÿÿËu‹E‰U´‹U$‰}¬‹},‰u¼‹M ‰E°‹u‰U ‹E(‰}œ‹U<‰M¸‹}œ‰u¨‹M ‰E„‹u0‰U€‹E@‰M¤‹M8‰u˜‹7‰M”‰E‰uŒ‹M4‹‰Uˆ‹ƒ…À…W‹u¼‹…É„Ê‹»$…ÿ…싃(…À„ñ‹M¸»³‰½hÿÿÿ¶úÿÿ‹‹ÿA‰t$‹}€‰t$‹ƒ4TÇø‰T$ ‹U¤‹M´‰T$‰ $èüÿÿÿ‹u”‹»4‹ƒ0‹U¼‰>‰FÇÄÜ[^_]ËM¸¶éœõÿÿ‹u¤»‹U´‰|$‰t$‰$èüÿÿÿ‹E ÙÀÝéõóÿÿ“ ‰$èüÿÿÿÙƒ‹ƒØ« Ø@lÙXlé òÿÿ‹‹ÿA‹•\ÿÿÿ‹³4‰T$‹}€‰T$D÷ø‰D$ é;ÿÿÿ‹‹@Aƒù‰‹@ŽÏùÿÿ‹‹Dƒ‹UI‰ ‰$èüÿÿÿÙƒ‹»‹u¼Ø«ØGÙ_Çcékûÿÿ¶‰t$‹ƒ0‹}€‰t$‹U¤LÇø‰L$ ‹E´‰T$‰$èüÿÿÿÙá‹}¨‹ÙúÝ›Xéqñÿÿ‹½\ÿÿÿ‹ƒ0‰|$‹U€‹}¤tÂø‹E´‰t$ ‹\ÿÿÿ‰|$‰$‰L$èüÿÿÿ‹u¸¶é?ôÿÿÿGº‹u”‰“(‹E¼‹‹4‹»0lj‰~é´úÿÿ‹»ÙÀÿG ‹³<F‰³<N~WÝØÝØ‹M´‹Jx‹E¤t&ÇÇ@ƒÀJyí‹U ÇÇBé ôÿÿ‰t$‹M¤‹U´‰L$‰$èüÿÿÿéHûÿÿÙÉ‹u Ýé6òÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹u¸Ø« Ø@lÙXl¶¨F(S@`X‡\—\#  .  ±ñÿ  #(08@ I$R([,c0j4q8x<€@ˆDH—P¡Xª`´É   Þã é î ôúÿ   W% <RYa |òÿi `òÿpw~…Œ”œ¢ªdsaitr.ft0.0t1.1t2.2t3.3t4.4t5.5first.6orth1.7orth2.8rstart.9step3.10step4.11ierr.12ipj.13irj.14ivj.15iter.16itry.17j.18msglvl.19rnorm1.20wnorm.21safmin.22__g77_forceload_0.23__g77_forceload_1.24.LC2.LC10.LC8.LC12.LC14.LC6.LC4.LC7.LC16dmout_daxpy_dsaitr___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_dgemv_arscnd_timing_debug_ivout_dscal_dvout_dcopy_dlamch_dgetv0_ddot_dlascl_dnrm2_1 2} ˜ ¦ · ½ $Ù   %6 @ &Q t |3’ ¹ 'Ð à3æ ì   ) 14> D R4z “ (™ ®5· Æ $Ñ %á ý   &0 =3Y u '‰ ¡3§ ¶ Ç à ê ö4" , 6 A K6Q $l7r  (ˆ ¥ ³ Á Ï )Õ á í þ    4 5' 3 9 *p $} '8“   ´ ¼4 È5Ñ Ý ð 659` €9’ œ4¢ ¨5± ½ Ã É $ë:ý  4+ L:b n4t6€ ‹ “ œ ® µ Ã Ë Ñ × é ï û; , @ M *c i | †6Œ $£7©5¯ º )Ã Ï ã Q <c r $~ © :¯ Ç +Ø ÿ 8 & 8, 57 = G 4S o ‹ :” š   Æ ç :  4  5 . B $H m =‚ ’ ³ =½ Ú ä %ü  " &F $S 'u ‚ Ž ,› 6¶ 9Ö ô & 0 >S  >˜ £ ­ 6Ä $Ô 7ß 95# =:F L y $Œ?ž ¦4¬ ²5¸ É5Ø ö      4& ,55 V w=† — Â:Þ ç í 5  j? ‰4 •5ž µ $» à=ê ý    ,09> $Q?./dsapps.o/ 1189291778 1000 1000 100644 5796 ` ELF,4( U‰åWVSìL‹}‹uèüÿÿÿËU‹E‰}´‹} ‰u¬‹u,‰U¨‹U4‰…Hÿÿÿ‹E‰½äþÿÿ‹M ‰µ`ÿÿÿ‹}$‰•Lÿÿÿ‹u0‰E¤‹‰M°‹M(‰Eœ‹ƒ‰M ‹…À‰M˜‹‰U”…ÌÇEˆ‹‰ $èüÿÿÿ‹“‹}¬‹M°‰U€‹B‹‹‰E„‹¿‰t$‹µ`ÿÿÿЉEè“Eè‰|$»‰t$‰8ÿÿÿ‰L$‰•4ÿÿÿ‰T$ ‰…Dÿÿÿ‰D$‰D$‰½0ÿÿÿ‰<$èüÿÿÿ‹u¬‹…À„%ÇEàH‰…|ÿÿÿˆÄƒ‹M€»‰…,ÿÿÿ‹E€U䉽(ÿÿÿƒÁ»(‰üþÿÿ‹uèMà‰•$ÿÿÿ“L‰… ÿÿÿE؉½ÿÿÿ}ЉÿÿÿMȉ•ÿÿÿUÀ‰…ÿÿÿE¸‰½ ÿÿÿ»‰ÿÿÿ‰•ÿÿÿ‰…ÿÿÿ‰½\ÿÿÿ‹Uˆ‰UŒ‹EŒ‰÷‹MŒ)ljMä‰ùIˆ‹Ýƒ‹½(ÿÿÿ‹•üþÿÿ‹… ÿÿÿ‰½xÿÿÿ‹½ÿÿÿ‰•tÿÿÿ‹•ÿÿÿ‰…pÿÿÿ‰½lÿÿÿ‰•hÿÿÿ¶¼'‹Uä‹E˜‹½äþÿÿÐÝDÇøÝÇÙÉÙáÙÉÙáÞÁÝ×ÙÉØÊÚéßàžƒ>BI‰EäyÆÝ؉u‹M9MŒŒ@‹MÙî‹u‹½äþÿÿA‰MŒÝD÷øÙÉÝéßàž‡ÚÝØ‹uè9uŒÿÿÿ‹Uˆ‰÷)׉ùIx-Ùƒ‹Eˆ‰Eäë ÿEˆBIx‰Uä‹U䋽äþÿÿÝ×ÝéßàžvãÝØÿEàÿ|ÿÿÿ‰Ñþÿÿë‹u苉,ÿÿÿ‹Eˆ‹Uˆ)ƉUäNˆ ‹ƒ»M䉽XÿÿÿP‰@ÿÿÿ»L‰•øþÿÿ‰…Tÿÿÿ‰½Pÿÿÿ‹Uä‹}˜‹äþÿÿ×ÝDùøÝùÙÉÙáÙÉÙáÞÁÝÑÙÉÜ‹Úéßàž‚¨‹E„…ÀŽ‡‹•Xÿÿÿ¹#‹½@ÿÿÿ‰L$‹…øþÿÿ‹,ÿÿÿ‰T$‹•Tÿÿÿ‰|$‰L$‰$‰D$ èüÿÿÿ¸.‹½Pÿÿÿ‹øþÿÿ‰D$‹•äþÿÿ‹Eä‰|$‰L$ <‹,ÿÿÿ‰|$‹•Tÿÿÿ‰L$‰$èüÿÿÿ‹U䋽äþÿÿ1ÀÇ׉D׋UäJN‰Mä‰ÿÿÿÙƒ‹U°‹µäþÿÿ‹ ÝÎÚéßàž‡+ÇEä‰ÎNˆê»zE쉽ôþÿÿ‰…<ÿÿÿë‹U°‹ ‹•4ÿÿÿ¿‹…Lÿÿÿ‰|$,‹½,ÿÿÿ‰T$ ‹Uä‰|$(‰|$‹}”)щD$$¯ù‹`ÿÿÿù‹}¤‰D$‹8ÿÿÿ‹…Hÿÿÿ‰|$‹}è‰D$‹E´)׉L$ ‹•<ÿÿÿG‰}ì‹ôþÿÿ‰D$‰T$‰ $èüÿÿÿ‹}ä‹Eè‹Uœ‹,ÿÿÿ)ø¯Â‰L$‹½Hÿÿÿ‰L$‹M´ljT$ ‹…Lÿÿÿ‰ $‰D$èüÿÿÿÿEäN‰-ÿÿÿ‹U¤¹‹µHÿÿÿ‰L$‹}¬‹Mœ‰T$‰t$‰T$‹‹}´¯È‹E°‰|$΋0ÿÿÿ‰T$ ‰D$‰ $èüÿÿÿÙƒ‹U°‹µäþÿÿ‹ ÝÎÚéßàž‡³Qÿ‹M”‹E ‹µ,ÿÿÿ¯Ñ‹½`ÿÿÿ‰D$‹Eè‰t$ 4׋U´LÆø‰L$‰$èüÿÿÿÙƒ‹u°‹½äþÿÿ‹Ý×Úéßàž‡ƒ}„4$èüÿÿÿÙƒ‹“Ø«ØB(ÙZ(ÄL[^_]ù“{‰L$‰$èüÿÿÿ1ÀÝ›‰ƒé úÿÿÙàÝ\÷ø‹M”‰÷O‹…,ÿÿÿ‹•`ÿÿÿ¯ù‹µDÿÿÿ‰D$ ‰4$ú‹½\ÿÿÿ‰D$‰|$èüÿÿÿéåûÿÿ‹UŒ‹u˜‹Eà‹M¨Ö‹•äþÿÿ‹}ŒÝDÁø‹ÿÿÿ‹… ÿÿÿÜlòøÝ]¸Ýú‹½ÿÿÿ‰L$‹•ÿÿÿ‰D$ ‹ÿÿÿÝ]À‰|$‰T$‰ $èüÿÿÿÝEÈ‹…äþÿÿ‹}ŒÝEЋUàÝøÝDðøÝðÙÂÙÂÙÂÙÊØÎÙÍØÏÙÉØÏÙÊØÎÙËØÏÙÊØÅÙËØÁÙÌØÎÙÌØÎÙËØÏÙÊÞåÞãÞÁÙÃØÊÙÊØÍÙÉÝ\ðøÙÄØËÙËØÌÙËÞâÞÂÝðÝø‰øЋUè9Ð~‰ÐH‰…àþÿÿx_‹MŒ‹U”‹}”Aÿ¯Â‹µ`ÿÿÿ¯ù Æþë ÝÝÙÁÙÁÙÉØÍÙÉØÌÙÊØÍÙËØÌÙÉÞÂÞêÙÉ݃À݃ÁÿàþÿÿyÎÝØÝØ‹}Œ‹uG‰}ä)þN‰µdÿÿÿ´&ˆUúÿÿ‹Uä‹äþÿÿÝDÑøÝ]¸ÝÑÙÀÜMÐÙÉÜMÈÙÉÝ]ÀÝÑ‹…ÿÿÿ‹½ ÿÿÿ‹µÿÿÿ‹•ÿÿÿ‰D$‹ÿÿÿ‰|$ ‰t$‰T$‰ $èüÿÿÿÝEØÙîÝéßàžv Ùà€uÏ€€u×€ÝUØÝEÈ‹Mä‹•äþÿÿÝEÐÙÊ‹uàÝ\Êø‹E˜‹½äþÿÿ‹UèÈÝDÇøÝÏÝÇÙÂÙÂÙÂÙÉØÏÙÌØÎÙÊØÎÙÉØÏÙÍØÏÙÉØÄÙÍØÂÙËØÎÙËØÏÙÍØÎÙÊÞáÙÊÞãÞÃÙÄØÉÙÉØÌÙËÝ\ÇøÙÃØÊÙÊØÍÙÊÞáÙÊÞÁÙÉÝljÈðÝÏ9Ð~‰Ð‰ÆNxV‹}”Aÿ‹U”¯Ï‹½`ÿÿÿ¯Â‰ìþÿÿ‹•ìþÿÿ Ç×fÝÝÙÁÙÁÙÉØÌÙÉØÍÙÊØÌÙËØÍÙÉÞÂÞêÙÉ݃À݃ÁNyÓÝØÝØÿEäÿdÿÿÿéþÿÿÝØ‹u„…öŽº‹½$ÿÿÿ¸#‹•xÿÿÿ‰D$‹tÿÿÿ‹µpÿÿÿ‰|$‹½,ÿÿÿ‰T$‰L$ ‰|$‰4$èüÿÿÿ‰|$‹•lÿÿÿ¸$‰D$‹tÿÿÿ‹µÿÿÿ‰T$‹½pÿÿÿ‰L$ ‰t$‰<$èüÿÿÿ‰<$‹tÿÿÿ¸.‰D$‹•hÿÿÿ‹Eä‰L$ ‹µäþÿÿ‹,ÿÿÿ‰T$ƉT$‰L$èüÿÿÿ‹U䋽äþÿÿ1öÇ׉t׉Uéî÷ÿÿº‹}´‹µLÿÿÿ‰T$,‹•,ÿÿÿ‰T$(‹‹½4ÿÿÿ‰T$Æ‹u”‰D$$‹•`ÿÿÿ‰|$ ¯ñ‹M¤‹½Hÿÿÿ‰L$ò‹•8ÿÿÿ‰D$‹µDÿÿÿ‹z‰|$‹E´‰ $‰T$ ‰t$‰D$èüÿÿÿ‹}°‹éKùÿÿ³Œ‹U°¸-‰t$‹³‹}”‰D$N‰ðþÿÿ‰L$ ‹‰4$‹`ÿÿÿH¯ÇÁ‹Eè|Âø‰|$‹½,ÿÿÿ‰|$èüÿÿÿ‹…ðþÿÿº,‹¼‰T$‹U°‰L$‹äþÿÿ‰D$ ‹‰|$‰4$Á‰T$èüÿÿÿ‰4$‹½ðþÿÿ¹5‰L$‹U˜ƒè‰D$‹äþÿÿ‰|$ ‹}°щD$‰|$èüÿÿÿ‹ƒúŽ8úÿÿ‰4$¸4‹½ðþÿÿ‰D$‹…äþÿÿ‹ ‰L$ƒÀ‰|$ Jÿ‰D$}ì‰Mì‰|$èüÿÿÿéôùÿÿ‹}œ‹,ÿÿÿ‹E ¯ú‹µHÿÿÿ‰L$‰L$ ‹äþÿÿ‰D$þ<щD$‹U´‰|$‰$èüÿÿÿé¥ùÿÿ‹Eœ‹µ,ÿÿÿ‹½Lÿÿÿ¯Á‹Hÿÿÿ‰t$‰t$Á‰T$ ‹U´‹ ‰$ωD$èüÿÿÿ‹u°‹éùÿÿAll_sapps: deflation at row/column no._sapps: occured before shift number._sapps: the corresponding off diagonal elementNEpsilon-Machine_sapps: sigmak of the updated residual vector_sapps: betak of the updated residual vector_sapps: updated main diagonal of H for next iteration_sapps: updated sub diagonal of H for next iterationð?ð¿‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst8.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@³  Äà %ô +ø 0ø T8PEhRpyt‰t#—’\€  Üèñÿ  #(0 9>CHM R³ Zq‡ `òÿ–ž¥¬³ºÂÉ |òÿÑÙádsapps.ft0.0t1.1t2.2t3.3t4.4t5.5first.6epsmch.7.LC1.LC2.LC5.LC9.LC8dsapps___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_dlaset_ivout_dvout_dgemv_dcopy_dlacpy_dscal_timing_dlamch_dlartg_daxpy_ i ‹ “™­ Ì Ù 4 = X p © ã º û  7 s È 9 h  B!˜"ž ð#ö  '- 3$9 U a%i o ²#&}&ç  _ â ý   _ p š µ Ö ÿ e '¥ !dsaup2.o/ 1189291778 1000 1000 100644 9856 ` ELFL4( U‰åWVSì‹U‹E èüÿÿÿË}‹M‰UÄ‹u‰EÀ‹U‰}¼‹E ‰M¸‹}$‰u´‹M(‰U°‹u0‰E¬‹U4‰}¨‹E8‰M¤‹}<‰u ‹M@‰Uœ‹uD‰E˜‰}”‰M‰uŒ‹EL‹MT‹UH‹uX‰…hÿÿÿ‹E`‰M„‹MŒ‰•dÿÿÿ‹U\‰µlÿÿÿ‹}P‰…Xÿÿÿ‹1‰U€‹Uĉµxÿÿÿ‰}ˆ‹‹}d…À‰½|ÿÿÿ„¸‹ƒ…À…ú‹³$»H…ö„›‹…|ÿÿÿ¹¾‰‹$‹M€‰t$<‹uŒ‰D$8‹•Xÿÿÿ‰L$0‹E‰t$,‹M˜‰|$‹u¨‰T$4‹U”‰D$(‹E¤‰T$$‹U°‰L$ ‹M´‰t$‹u¼‰D$‹EÀ‰T$‹UĉL$ ‰t$‰D$‰$èüÿÿÿ‹Mă9c„öÄ[^_]˃(…À„®‹U ‹1ö…À‰³(„‘ƒ»4Ú‹Xÿÿÿ‹E„‹Uˆ‰L$,‹}¨‹uŒ‰D$(‹M‹E”‰T$$‹U˜‰t$‹u°‰L$‹M´‰D$‹E¼‰T$‰|$ ‹½dÿÿÿ‰t$‰L$‰|$ »‰$èüÿÿÿ‰<$º‰“èüÿÿÿ‹uÀ¶|…É…=‹M¸“`¸‰D$¿‰|$ ‰•Pÿÿÿ‰T$‰ $èüÿÿÿ…À…™»b¸¹‰|$}ʉD$ ‰L$‰<$èüÿÿÿº‰T$‹µhÿÿÿ‰t$‹…dÿÿÿ‰D$ ‹Tÿÿÿ‰L$‹•@ÿÿÿ‰T$‰½Dÿÿÿ‰<$èüÿÿÿ‹“<ƒd‹M´‰…Lÿÿÿ‰ÖÁî<2Ñÿ‰Ö)þƒ9Žñ‹…@ÿÿÿ‹M°‰D$‹ƒ0‹ ‰Â)ú)ȉ$ÿÿÿÕÅ9Â}‰Â‹dÿÿÿÁæD ø‰D$ ‹…@ÿÿÿ‰T$‰D$‹…$ÿÿÿ9ø~‰ø‰EÔMÔ‰ $èüÿÿÿ‹…@ÿÿÿ‹M°‰D$‹ƒ0‹ ‰Â)ú)ȉ$ÿÿÿÕÅ9Â}‰Â‹hÿÿÿD ø‰D$ ‹…@ÿÿÿ‰T$‰D$‹…$ÿÿÿ9ø~‰ø‰EÐ}гd‰<$èüÿÿÿ‹“<‰µLÿÿÿ‰ÑIx0݃P‹½hÿÿÿ‹•dÿÿÿÝÙáÝáßàžsÝØÙÀÜ?ƒÂ݃ÇIyäÝغ¿‰T$ ‰|$‹Lÿÿÿ‰L$‹µDÿÿÿ‰4$èüÿÿÿ¸‹<‰D$‹•dÿÿÿ‰T$‹½hÿÿÿ‰L$‰|$ ‹µ@ÿÿÿ‰t$uʉ4$èüÿÿÿ‹‹<Ix0݃P‹½hÿÿÿ‹•dÿÿÿÝÙáÝáßàžsÝØÙÀ܃Â݃ÇIyäÝظº‹M¸‰D$ ‰T$‹½Pÿÿÿ‰ $‰|$èüÿÿÿ…À…׺¿‰T$ ‰|$‹Lÿÿÿ‰4$¾‰L$èüÿÿÿ‰t$‹…hÿÿÿuʉD$‹•dÿÿÿ‰T$ ‹½Hÿÿÿ‰|$‹@ÿÿÿ‰4$‰L$èüÿÿÿ݃H‹uƒ»4Ý~‹Eœ‹“,9}J‹u´‹ƒ89~ ‹|ÿÿÿÇ‹u°‹>…ÿu;ƒ<} ‹|ÿÿÿÇ‹u°‹Mœ‹}´‰‰‰éYöÿÿ‹ƒ8ëǸ‰D$‹•hÿÿÿ‹E¸‰T$‹½dÿÿÿ‰|$ ‹Hÿÿÿ‰L$‹µ@ÿÿÿ‰$‰t$éHÿÿÿ‹U¸¸¹‰D$ ³f»h‰$‰L$‰t$èüÿÿÿ…ÀUʉ•Dÿÿÿ„º‰|$‹}¸¸‰D$ º‰T$‰<$èüÿÿÿ…À„h‹U¸ƒd¹‰L$ ¾»b‰t$‰Æ‰…Lÿÿÿ‰D$‰$èüÿÿÿ…À„‰|$‹}¸¸‰D$ º‰T$‰<$èüÿÿÿ…À„°º‰T$‹½hÿÿÿ‰|$‹dÿÿÿ‰L$ ‹µTÿÿÿ‰t$‹…@ÿÿÿ‰D$‹•Dÿÿÿ‰$èüÿÿÿ‹“<éÓüÿÿ‹³j‹»8‹U°‰Eظ‹ ‰}à‹»U؉MÜ‹‰t$w‰D$‰½`ÿÿÿ‰t$ ‰T$‰L$‰<$èüÿÿÿ‰t$ “„¸‰T$‰D$‹dÿÿÿ‰L$‹½Tÿÿÿ‰|$‹…`ÿÿÿ‰$èüÿÿÿ‰t$ º5‹ ‰T$‰L$‹½hÿÿÿ‰|$‹…Tÿÿÿ‰D$‹µ`ÿÿÿ‰4$èüÿÿÿéòùÿÿ¿‹Õ‰|$‹»‰L$w‰½\ÿÿÿ‰µ4ÿÿÿ‰t$ ‹…dÿÿÿ³ð‰D$‹•Tÿÿÿ‰<$‰T$èüÿÿÿ‰t$¹‰L$‹…4ÿÿÿ‰D$ ‹•hÿÿÿ‰T$‹½Tÿÿÿ‰|$‹\ÿÿÿ‰ $èüÿÿÿéöüÿÿ‹E´‹09Ö~ ‹} ƒ?„L‹‹4…É~I³¿4‰t$‹³‰|$~‰|$ ‹…Hÿÿÿ‰D$‹•@ÿÿÿ‰4$‰T$èüÿÿÿƒ»4D‹u ‹…À…3ðÿÿ‹}ʼn‹(Çéüïÿÿ¸7‹u´“D‰D$‹ƒ‰T$H‰<ÿÿÿ‰…tÿÿÿ‰t$³‰L$ ‰t$‰$èüÿÿÿ‹|º+‰T$‹U°‰L$‹…<ÿÿÿ‰T$‰t$‰D$ ‹tÿÿÿ‰ $èüÿÿÿéÄðÿÿ‰t$¿¹‰|$ ‰L$‹µDÿÿÿ‰4$èüÿÿÿé'ýÿÿ‰|$¹¸‰L$ ‰D$‹•Dÿÿÿ‰$èüÿÿÿéÕüÿÿ‰t$¿¹‰|$ ‰L$‹µDÿÿÿ‰4$èüÿÿÿéoüÿÿ‰|$¹¸‰L$ ‰D$‰$èüÿÿÿé#üÿÿ‹U´‹M°‹º‰EØ‹‹§‰EÜE؉T$“‰L$‰|$ ‰T$‰D$‰4$èüÿÿÿ‰|$ ‹U°ƒ½‰D$¹‰L$‹dÿÿÿ‹‰4$Á‹M´‰T$‰L$èüÿÿÿ‰|$ ‹M°“܉T$¸.‰D$‹‹½hÿÿÿ‰4$‹M´ljT$‰L$èüÿÿÿéþÿÿ‰ÈÁèÑø9Ð~‰Ðƒøtm‹U´‰‹“0‹M´‹ƒøtt‹M°)Â9ð‰Žxýÿÿ¿‰|$‹µlÿÿÿ‹}´‰t$‹…hÿÿÿ‹u ‰D$‹•dÿÿÿ‰L$ ‹M¸‰T$‰|$‰L$‰4$èüÿÿÿé/ýÿÿ‹“0ƒú~&‰×‹M´Áï:Ñø‰댃ú~‡Ç¸éwÿÿÿ‹E´Çé_ÿÿÿ_saup2: **** Start of major iteration number ****Epsilon-Machine_saup2: B-norm of residual for NEV factorization_saup2: main diagonal of compressed H matrix_saup2: subdiagonal of compressed H matrix_saup2: The number of shifts to apply _saup2: shifts selected_saup2: corresponding Ritz estimates_saup2: Current B-norm of residual for factorizationBESALALMSM_saup2: NEV, NP, NCONV are_saup2: The eigenvalues of H_saup2: Ritz estimates of the current NCV Ritz values_saup2: Sorted Ritz values._saup2: Sorted ritz estimates._saup2: no. of "converged" Ritz values at this iter._saup2: The length of the current Lanczos factorization_saup2: Extend the Lanczos factorization by_saup2: NEV and NP are_saup2: "wanted" Ritz values._saup2: Ritz estimates of the "wanted" values UUUUUUå?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst8.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ H 0%X+XX4X0 x&>\ FhSp`„‡ˆ—ˆ#« Ìà& ¬›ñÿ  #(08 @$I(S,[0e4o8x<€@‡HP™   ® ³ ¸½  È  ÎÕÝ ô " `òÿ)08@D |òÿLSZ`gow…Œ”dsaup2.ft0.0t1.1t2.2t3.3t4.4t5.5cnorm.6getv0.7initv.8update.9ushift.10iter.11kplusp.12msglvl.13nconv.14nev0.15np0.16rnorm.17eps23.18__g77_forceload_0.19.LC2.LC3.LC1.LC4.LC10.LC22dscal_dsaup2___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_dsaitr_dsapps_arscnd_debug_ivout_dgetv0_dlamch_powtiming_dvout_dcopy_ddot_dnrm2_dseigt_dsgets_dsconv_s_cmps_copydsortr_dswap_( )Ê Ø Þ ü j*‡ ž ª   +# (,V \ b q { † -š ±.· Ý    @/R X ‚  •,›-­ ²0¸ !Æ1Ì × æ ÷ ÿ     % 8 C d ‹ › ©,¯ µ2» Ï Ú ä-3 A3L €3† ‘ £-© Ä.Ó ô3 03; b4³ Ò "æ* ( 9 A,G M2V m ‘5› © ¼6Ä2Ê ö4 @4M T ƒ ¡7È Ò-Ø ï3ú  3 49 h 4n |  8 4 E 9K b ’ ˜ £ ¸ Ü :ê  ;J <P V ‰ ç =ú S [ =a r Æ ;Ñ  <  b :“ ;Ê <Ð Ù ë ø  ? ” š ª:Ü:í  :B:‰< œ ¢ ¸-Ä #é.ó "31 [3k u-˜ ®3ç3   -G.M o ˆ ’-¯ ¿.Å õ.;G;p;“;° À $Ø.å 3 H3p Í8Ø &dsaupd.o/ 1189291778 1000 1000 100644 6896 ` ELF4( U‰åWVS켋M ‹UèüÿÿÿËu‹E‰Mì‹M$‰Uð‹}‰uà‹u<‰Eè‹E0‰MØ‹Mð‰}ä‹U‰uÈ‹}4‰EÔ‹‰UÜ‹UD…À‰}ЉUÌ„0‹“X‰U´‹³‰u°‹»$‹‹0º¾‹ẺT$d‹U8‰t$`‹uЉD$\‰T$X‰t$T‹uÈDÎø‰D$PTþø‹8‰T$H‰L$L‹}°Dþø‰D$D‹ƒ ‹M´»4‰|$ùÿÿ‹u为‰D$ »–‰T$‰|$‰4$èüÿÿÿ…À„íúÿÿ‹M亿‰T$ ³˜‰|$‰t$‰ $èüÿÿÿ…À„¾úÿÿ‹Eä‹š¿‰|$ ¾‰t$‰L$‰$èüÿÿÿ…À„úÿÿ‹U乃œ‰L$¾‰t$ ‰D$‰$èüÿÿÿ…À„`úÿÿ¿ûÿÿÿ‰»éPúÿÿ‹Uàƒ:…›úÿÿ‹u乸‰L$ »œ‰D$‰|$‰4$èüÿÿÿ…À…lúÿÿºóÿÿÿ‰“é\úÿÿv¾üÿÿÿ‰³éÃùÿÿ‹UØ¿ÿÿÿÿ‹Mà‹‹é™ùÿÿ‹MØ¿þÿÿÿ‹éŠùÿÿ¹»ž‰L$‰<$èüÿÿÿ‹uÜÝéâýÿÿ€ùG…ýÿÿ¸õÿÿÿéìùÿÿÇéjúÿÿ¹‰‹Héœýÿÿ(/,/,5X,==========================================,/,5X,= Symmetric implicit Arnoldi update code =,/,5X,= Version Number:, 2.4,19X, =,/,5X,= Version Date: , 07/31/96,14X, =,/,5X,==========================================,/,5X,= Summary of timing statistics =,/,5X,==========================================,/,/)(5X,Total number update iterations = ,I5,/,5X,Total number of OP*x operations = ,I5,/,5X,Total number of B*x operations = ,I5,/,5X,Total number of reorthogonalization steps = ,I5,/,5X,Total number of iterative refinement steps = ,I5,/,5X,Total number of restart steps = ,I5,/,5X,Total time in user OP*x operation = ,F12.6,/,5X,Total time in user B*x operation = ,F12.6,/,5X,Total time in Arnoldi update routine = ,F12.6,/,5X,Total time in saup2 routine = ,F12.6,/,5X,Total time in basic Arnoldi iteration loop = ,F12.6,/,5X,Total time in reorthogonalization phase = ,F12.6,/,5X,Total time in (re)start vector generation = ,F12.6,/,5X,Total time in trid eigenvalue subproblem = ,F12.6,/,5X,Total time in getting the shifts = ,F12.6,/,5X,Total time in applying the shifts = ,F12.6,/,5X,Total time in convergence testing = ,F12.6)`LM_saupd: number of update iterations taken_saupd: number of "converged" Ritz values_saupd: final Ritz values_saupd: corresponding error boundsSMLASABEEpsMach‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@â hx %@ 8 +x\4x(0 à D ¥LHYP€TT#w™hp( Øñÿ  #(18 =$B(L,T0Z4a8h<r@|D„HŠL’PšT X¨ºXÏá`Ø  öû â 5=EM `òÿTZ |òÿbipw~…dsaupd.ft0.0t1.1t2.2t3.3t4.4t5.5bounds.6ierr.7ih.8iq.9ishift.10iupd.11iw.12ldh.13ldq.14msglvl.15mxiter.16mode.17nb.18nev0.19next.20np.21ritz.22__g77_cilist_0.24__g77_format_1000.23__g77_cilist_1.26__g77_format_1100.25.LC8.LC5dsaupd___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_dsaup2_dstats_arscnd_debug_s_cmptiming_ivout_dvout_s_wsfee_wsfedo_fiodlamch_) *h q z € ¼ Õ Þ ÷     / 9 p+—, ¥-«.Á Ç Ð Ý å ð # / F !V/y ˜ ž µ » å ü   0> L !W %a.‚1‘ !¯1¾ !È æ2õ !ÿ 2# +-1 : C Q W _3d4q3‡ %5§5½5Ø5ø55)5D5d55•5°5Ð5ë55575<4N ` r € &¦ ± Õ à î ü     $ Y !i/ˆ !˜/© !Ç/Ý !ö/  1 !A/T g š !¦6Ù   dsconv.o/ 1189291778 1000 1000 100644 1628 ` ELFÔ4( U‰åWVSƒì‹uèüÿÿÿË‹}‰ $èüÿÿÿºƒ‰T$‰$èüÿÿÿ݃ÙÉÝ$Ý\$èüÿÿÿÇ‹Ix=‹u‹UÝ‹u ´&ÝÙáÝâßàžsÝØÙÁÙÁÞÉÝÙÉÚéßàžrÿƒÆƒÂIy×ÝØÝØ“‰$èüÿÿÿÙƒ‹»Ø«ØG,Ù_,ƒÄ[^_]ÃEpsilon-MachineUUUUUUå?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst8.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@Ë ôh % + 0 8 E(l,|,#O…Ü  l…ñÿ  #( - `òÿ4 |òÿ<ËD[qydsconv.ft0.0t1.1t2.2t3.3t4.4t5.5.LC1debug_timing_dsconv___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_dlamch_pow   $/ ;A OŸ §­ ³¹ dseigt.o/ 1189291778 1000 1000 100644 2136 ` ELFx4( U‰åWVSƒìL‹}‹M èüÿÿÿËE ‹u‰}è‹}‰MÌ‹U‰Eì‹E$‰uä‹7‰Uà“‰u؉$‰EÜèüÿÿÿ‹³Mð‹Uè‹Fz‰MÈ…À‰EÔ~J‰4$‹¸!‰L$‹M؉D$F‰EЉD$ Ê‹Uì‰D$‰T$èüÿÿÿ‹Mì‹Mð‰Mȃúê‹E䳋U؉t$‹Mè‰D$ ‰t$Ñ‹Uì‰D$‰$èüÿÿÿ‰t$‹EÌ‹Mì‰t$‹uȉ|$‰D$ ‹‰4$J‰Uðèüÿÿÿ‹}Ü‹Eì‹uà‰|$‹‹}̉t$ ‹Eä ׉L$‹Uì‰|$‰D$‰$èüÿÿÿ‹MÜ‹1…öuRƒ}Ô‹‹uì‹Jx‹M‹EàÝfÝÙáØÉ݃ÀJyòÝ؃‰$èüÿÿÿÙƒ‹“Ø«ØB ÙZ ƒÄL[^_]ÉL$¿ ƒ$‰|$‹}ЉD$Bÿ‰|$ ‹}è‰Eð‰4$ƒÇ‰|$èüÿÿÿéÛþÿÿ¿0‹MàƒD‰|$‹»‹uì‰D$W‰T$ ‰L$‰t$‰<$èüÿÿÿé:ÿÿÿ_seigt: main diagonal of matrix H_seigt: sub diagonal of matrix H_seigt: last row of the eigenvector matrix for H‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ °¨ %T+T0Tt8ÈEÌlÐ|Ð#ó…€    ñÿ  #( -5Lbj `òÿqx‡ |òÿdseigt.ft0.0t1.1t2.2t3.3t4.4t5.5.LC2dseigt___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_dvout_dcopy_dstqrb_timing_ < JPo œ¹ Ý7r z€ †Œ © Ðã í dsgets.o/ 1189291778 1000 1000 100644 2560 ` ELFŒ4( U‰åWVSƒì<‹}‹MèüÿÿÿËU‹E‰}介u ‰M܉U؉<$‰Eàèüÿÿÿ‹ƒ¹º‹x ƒ‰L$ ‰T$‰D$‰4$èüÿÿÿ…À…Q‹uع‹E܉L$‹Uà‹Mä‰t$‰D$ ‹1‹‹Uð‰T$ð‰Eðƒ‰MÔ‰L$‰$èüÿÿÿ‹u䋉ÊÁê4ÑþIŽ5‹UÔ‹Eà‰T$‹9ò‰ÐŒ<‹MÜ9òÁ‰D$ ‹EÔ‰L$‰D$‰Ð~‰ð‰EìEì‰$èüÿÿÿ‹UÔ‹Mà‰T$‹9ò‰Ð}‰ð‹MØ9òÁ‰D$ ‹EÔ‰L$‰D$‰Ð~‰ð‰Eèuè‰4$èüÿÿÿ‹uƒ>…µt&‹Uà‹…ÀŽ¤‰T$‹uع‰L$‹UÔ‹‰ $‹E܉t$ ‰T$‰D$èüÿÿÿ‹uÔ‹E ‹U܉t$‹Mà‰D$ ‰t$‰T$‰ $èüÿÿÿëN‹Mغ‹E܉T$‹Uà‰L$‹Mä‰D$ ‹‹‰4$Mè‰L$Г‰Eè‰UÔ‰T$èüÿÿÿ‹uƒ>„Oÿÿÿ³‰4$èüÿÿÿÙƒ…ÿ‹“Ø«ØB$ÙZ$ŽÛ»‹U侉|$‹»‹MÔ‰t$w‰t$ ‰T$‰L$‰<$èüÿÿÿ‰t$ ¸ ‹Mà‰D$‹EÔ“‰T$‰L$‰D$‰<$èüÿÿÿ‰t$ ‹Eܺ'‰T$‹$‹Uà‰L$‹Mä‰D$‹‹‰<$ЉEèEè‰D$èüÿÿÿ‰t$ ¹!‹u؉L$‹Eà“L‰T$‹Mä‰t$‹0‹‰<$Eì‰D$Ö‰uìèüÿÿÿƒÄ<[^_]Éðé½ýÿÿBELASM_sgets: KEV is_sgets: NP is_sgets: Eigenvalues of current H matrix_sgets: Associated Ritz estimates‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@)  ø %l+l0lm8ÜEàlä|ä#…”Ð  d£ñÿ  #( -)5Lbj `òÿqw† |òÿ•œdsgets.ft0.0t1.1t2.2t3.3t4.4t5.5.LC1dsgets___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_s_cmpdsortr_dswap_dcopy_timing_ivout_dvout_ % 9?R f“ § ¶ L‚ ™½ò  ! )/ A SqŠ ž´ Úó dneupd.o/ 1189291778 1000 1000 100644 13404 ` ELF°(4( U‰åWVS윋E‹U èüÿÿÿË}‹u‰…Tÿÿÿ‹M‰•Pÿÿÿ‹E‰½Lÿÿÿ‹U ‰µHÿÿÿ‹}$‰Dÿÿÿ‹u(‰…@ÿÿÿ‹M,‰•<ÿÿÿ‹E0‰½8ÿÿÿ‹U4‰µ4ÿÿÿ‹}8‰´þÿÿ‹u<‰…0ÿÿÿ‹M@‰•,ÿÿÿ‰½(ÿÿÿ‰µ$ÿÿÿ‰ ÿÿÿ‹M`‹EH‹UL‹}P‰Ðþÿÿ‹u\‰…ÿÿÿ‹Mh‰•ÿÿÿ‹ƒ‰½ÿÿÿ‹UT‰µ°þÿÿ‹}X‰ÿÿÿ‹p@‹B‰µìþÿÿ‹r“‰E˜Ç¹‰L$‰$èüÿÿÿ݃ÙÉÝ$Ý\$èüÿÿÿ‹E˜Ýþÿÿ…ÀŽ‹•,ÿÿÿ‹ …ÉŽ‹•$ÿÿÿ‹…ÀŽ5@‰…´ýÿÿ‹…ÿÿÿ‹;•´ýÿÿ~9ÊŽNÇEýÿÿÿFÿƒø†}ƒþ„Ƀþ„ô ÇEöÿÿÿN„‹v¼'‹E…Àt‹½ÿÿÿ‰Äœ[^_]ö‹G‹•ÿÿÿ‹O‰…äþÿÿ‹w‹‰ÿÿÿ‹O‰Â‰µèþÿÿ¯Ð‰ ÿÿÿÁ‰ÿÿÿÁ‹µÿÿÿ‰üþÿÿÁ‰ÿÿÿÁ‰ðþÿÿщôþÿÿ‹üþÿÿ‰EŒ‰E”‰O$‹ðþÿÿ‰w ‹µÿÿÿ‰O,‹O4‰w(‹µôþÿÿʉ•àþÿÿÂЉw0‹Ðþÿÿ‰•Üþÿÿ‹•ÿÿÿ‰…Øþÿÿ1ö1ÀÝDÑÝ`ÿÿÿ‰tщDÑ ƒ½ìþÿÿ½‹Tÿÿÿ‹…À„}‹½ÿÿÿ1ö‰µÔþÿÿ‹¿‰•´ýÿÿ‰ÖNxO‹• ÿÿÿ‹…Ðþÿÿ‹LÿÿÿTÐø‰•°ýÿÿ´&¼'W‹•°ýÿÿGÛ$ƒÄ݃ÂǃÁN‰•°ýÿÿyÛ‹•$ÿÿÿ¹‹½´ýÿÿ‹2ÇE )÷‰}¤‰L$$‹Ðþÿÿù‰L$‰D$ ‹µ ÿÿÿ|ñø‰½\þÿÿ‰|$‹…ÜþÿÿtÁø‰µXþÿÿ‰t$‹½àþÿÿu¤Dùø‹½(ÿÿÿ‰…TþÿÿM ‰D$‰t$ ‰T$‰|$‰ $èüÿÿÿƒ½ìþÿÿ¯ÇEœ‹•ÿÿÿ¸‹ ‰…þÿÿ‰ÏéÃÝØ‹…ÿÿÿ‹• ÿÿÿ‹µþÿÿ‹‹•Ðþÿÿ)ð‹uœÝDÂøÙ½^ÿÿÿ·…^ÿÿÿf ;u˜f‰…\ÿÿÿÙ­\ÿÿÿÛ°ýÿÿÙ­^ÿÿÿâ‹•°ýÿÿ‹…ØþÿÿЉ…´ýÿÿ‹• ÿÿÿÜ ‹•ÐþÿÿÝDÂðÙÉÚéßàžr3‹•°ýÿÿ‹…LÿÿÿÇDüF‹µ$ÿÿÿ‰Eœ9}º‰•Ôþÿÿt&ÿ…þÿÿOˆz‹µÜþÿÿ‹•þÿÿ1)Ћ•ÐþÿÿDÂø‰D$‹µàþÿÿ1‹µþÿÿ)ðLÂø‰ $èüÿÿÿÝ…þÿÿÙÉÝáßàž‚çþÿÿÝÙéâþÿÿº¸‹‰T$ U؉D$‰L$‰$èüÿÿÿN…üÿÿ‹µ0ÿÿÿ€>G…püÿÿÇEõÿÿÿédüÿÿÇEòÿÿÿé"üÿÿÙƒ‹µ4ÿÿÿÝÚéßàžu(z&º¹ƒ‰T$ ‰L$ë$ÇEþÿÿÿéåûÿÿ¸¾‰D$ƒ‰t$ ‰D$E؉$èüÿÿÿéïûÿÿÇE¹¸‰L$ ‹(ÿÿÿ“!‰D$‰T$‰ $èüÿÿÿ…À…w‹0ÿÿÿ¶A…éóÿÿ‹½ÿÿÿ¾‹Ix‹}˜‹•Lÿÿÿ1À9þžÀ‰FƒÂIy𺿵tÿÿÿ‰T$<‹•ÿÿÿ‰|$8‹øýÿÿ‰L$4‹…´þÿÿ‰t$,‰T$(‰D$0‹µxþÿÿ‰t$$‹•Ðþÿÿ‹½ôþÿÿLúø½hÿÿÿ‰L$ ‹…tþÿÿ‰|$‹½Lÿÿÿ‰D$‹…ÿÿÿ‰t$‹µðþÿÿ‰D$ ‰|$Lòø³è‰L$‰t$‹•`þÿÿ‰$èüÿÿÿ‹M…É„!‹µÿÿÿÇ÷ÿÿÿéNìÿÿº¹ƒî‰T$ ‹•(ÿÿÿ‰L$‰D$‰$èüÿÿÿ…À„Wðÿÿ¸º‹ð‰D$ ‹…(ÿÿÿ‰T$‰L$‰$èüÿÿÿ…À„%ðÿÿ¹¸“ò‰L$ ‹(ÿÿÿ‰D$‰T$‰ $èüÿÿÿ…À„óïÿÿº¹ƒô‰T$ ‹•(ÿÿÿ‰L$‰D$‰$èüÿÿÿ…À„Áïÿÿ¸º‹ö‰D$ ‹…(ÿÿÿ‰T$‰L$‰$èüÿÿÿ…À„ïÿÿÇEûÿÿÿéëÿÿ‹Pÿÿÿ¶DJ PÉ"Xo… `òÿŒ”˜ ¨¯µ¼ÃÊÒÚâêòù $+ |òÿdneupd.ft0.0t1.1t2.2t3.3t4.4t5.5.LC1.LC9.LC20.LC22.LC23.LC36.LC38dneupd___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_debug_dlamch_powdngets_dlapy2_s_copys_cmpdvout_dcopy_ivout_dlaset_dlahqr_dgeqr2_dorm2r_dlacpy_dscal_dtrevc_dtrsen_dmout_dger_dnrm2_dgemv_dtrmm_timing_ Äñ  ±å & Z { ¥ ¸ Þ î!e t¥"´ â"ñ "; r#¦#à##V [#‘!¥ ß! !t !s ˆ © "³ Ü "ë  " , C S $^ ƒ $˜ £ ò # + ; [ %ç &; #¶ » #å !K'­ ½ è(;)\ ï*9*D n!á'!” #A#] r“"¬ É"Ø "! ;!† ›¼"Õ ò" \ d*; Q+} —!¯ É!á û! -!E _!» Ú!î !J#‡#Ö*ª ´ È,å ú'"@ Z"v ¨-³ Âé õ"."= g" »-ØŸ#Ü#ú 6.K e!V/\ £*â//:F *Ú*O i0ü[ #¥ '2!(h! ! š! Â!1'" ,"#6"b""u" À"-dseupd.o/ 1189291778 1000 1000 100644 10180 ` ELFX4( U‰åWVS쌋u‹} èüÿÿÿËU‹M‰u”‹E‰}‹u‰UŒ‹} ‰Mˆ‹U$‰E„‹M(‰u€‹E,‰½|ÿÿÿ‹u0‰•xÿÿÿ‹}4‰tÿÿÿ‹U<‰…pÿÿÿ‹M@‰µlÿÿÿ‹ED‰½hÿÿÿ‰•dÿÿÿ‰`ÿÿÿ‰…\ÿÿÿ‹uL‹}P‹UT‹M\‰µXÿÿÿ‹µlÿÿÿ‰½üþÿÿ‹½dÿÿÿ‰•ÿÿÿ‹“‰Tÿÿÿ‹EH‹‹7‹z$‹P‰½4ÿÿÿ‹x‹…Tÿÿÿ‰U¸Çƒ}¸„Q‹•tÿÿÿŸÀ¶ÀH‹ƒàò‰•Äþÿÿ…ÒŽG…ÉŽW9Î~ ;µÄþÿÿŽ'ÇE´ýÿÿÿ‹pÿÿÿ¸º‰D$ ³‰T$‰t$‰ $èüÿÿÿ…À….‹µxÿÿÿ¶‹½Pÿÿÿ‹…ÿÿÿ‹UŒ|øø‰½ÀþÿÿV‹½ÀþÿÿFÛ$ƒÄ݃ÇǃÂI‰½ÀþÿÿyÛ‹µlÿÿÿ¿‹…Pÿÿÿ‹)•¼þÿÿ‹•ÿÿÿ‰|$‹¼þÿÿtÂø‰T$EĉMÄ‹,ÿÿÿ‰µðþÿÿ‰t$|Êø‹µlÿÿÿÇEÀ‹•pÿÿÿMÀ‰½ìþÿÿ‰|$‰D$ ‰t$‰T$‰ $èüÿÿÿƒ½4ÿÿÿoÇE¼‹…dÿÿÿ‹‰×OˆðÙ}ž‹u¸1À‰…Üþÿÿ‹Pÿÿÿ‰µ ÿÿÿ‹µ,ÿÿÿ ‹ÿÿÿòTÑðtÁð·MžfÉ f‰MœéfÝØÝ‹ ÿÿÿ9ÜþÿÿÙmœÛ´þÿÿÙmž¤‹…´þÿÿ‹(ÿÿÿÁ‰Àþÿÿ‹…hÿÿÿÜ‹…ÿÿÿÝDÈðÙÉÚéßàžr/‹´þÿÿ‹EŒÇDˆü‹…lÿÿÿÿ…Üþÿÿ9}¹‰ÿÿÿvƒêƒîOˆÝÝ…ÐþÿÿÙÉÙáÝáßàž‚\ÿÿÿÝÙÝ‹ ÿÿÿ9ÜþÿÿÙmœÛ´þÿÿÙmžŒ\ÿÿÿÝØ붶º¸M؉T$ ³‰D$‰t$‰ $èüÿÿÿO…bûÿÿ‹µxÿÿÿ€>G…SûÿÿÇE´õÿÿÿéGûÿÿ´&‹u”‹éÆúÿÿ‹•pÿÿÿ¹¾‰t$ »‰L$‰|$‰$èüÿÿÿ…À…ûÿÿÇE´ôÿÿÿéûÿÿÇE´ðÿÿÿé‰úÿÿ¹¿ƒ‰L$ ‰|$‰D$M؉ $èüÿÿÿéÀúÿÿ‹•Üþÿÿ‰U¼ƒ½4ÿÿÿ΋E¸9E¼„‹½TÿÿÿÇïÿÿÿé¯úÿÿ‹üþÿÿ»‹µtÿÿÿ‰|$‰L$‰4$èüÿÿÿÝ] é üÿÿ‹•,ÿÿÿ³(¿*‰t$‹ÿÿÿ‹³‰|$DÑø‹•dÿÿÿ‰D$~‰|$ ‰T$‰4$èüÿÿÿ‰|$ ¹-ƒT‰L$‹•(ÿÿÿ‹ÿÿÿ‰D$‹…dÿÿÿ|Ñø‰|$‰D$‰4$èüÿÿÿé%üÿÿ‹}ˆ³‹…0ÿÿÿ‰µôþÿÿU¸‰|$ ‹½ÿÿÿ‰t$‰t$tÇø‰•èþÿÿ‰$‰t$èüÿÿÿ‰t$‹Dÿÿÿ‹•ôþÿÿDÏø‰D$ ‹…dÿÿÿ‰T$‰T$‰$èüÿÿÿ¾“M؉t$ ¸‰D$‰•àþÿÿ‰T$‰äþÿÿ‰ $èüÿÿÿ…À…+‹M”‹9…ÿ„H‹µ@ÿÿÿ¹}°‰L$‹…ÿÿÿ‹dÿÿÿ‰|$Tðø‹}ˆ‰T$‹µèþÿÿ“‰L$‹E”‰|$ ‰t$‰D$‰$èüÿÿÿ‹U”‹:…ÿt ‹E€8A„\ ‹½àþÿÿº¸‰T$ ‹µäþÿÿ‰D$‰|$‰4$èüÿÿÿ…À…R‹u”‹…É„E‹½dÿÿÿ‹Jx$‹µHÿÿÿ‹ÿÿÿDñøfÝÙáÜÿÿÿ݃ÀJyî‹•àþÿÿ¸¿‰|$ ‹äþÿÿ‰D$‰T$‰ $èüÿÿÿ…À„´ƒ½4ÿÿÿ‹U”‹ …É…h‹àþÿÿº¿‰|$ ‹µäþÿÿ‰T$‰L$‰4$èüÿÿÿ…À„ò÷ÿÿ‹<ÿÿÿ‹µÿÿÿ‹}€‹U„DÎø‹µèþÿÿ‰|$ ‹½ôþÿÿ‹‰T$‹U8‰D$‹…tÿÿÿ‰|$‰|$‰T$ ‰L$‰t$‰$èüÿÿÿé”÷ÿÿ¸¾‰D$ ƒ‰t$éüÿÿ¿ºƒ‡‰|$ ‰T$édüÿÿ‹•àþÿÿ¹¿‰L$ ‹…äþÿÿ‰|$‰T$‰$èüÿÿÿ…À„¸þÿÿ‹E”‹0…ö„«þÿÿ‹µôþÿÿ} ‹ÿÿÿ‰|$‹…Hÿÿÿ»‰t$ ‹•dÿÿÿtÁø‰$‰t$èüÿÿÿ‰|$‹•äþÿÿ¸‰D$ ¹‰L$‰$èüÿÿÿ…À…Ÿ ‹•dÿÿÿ‹ Iˆ7þÿÿ‰ð‹½ÿÿÿ‹µ<ÿÿÿT÷ø݃ÂÝÙÉØÈÙÉÙáÞñ݃ÀIyçéþÿÿt&³‹ìþÿÿ¿)‰t$‹³‹…dÿÿÿ‰|$~‰|$ ‰L$‰D$‰4$èüÿÿÿ‰|$ ‹…dÿÿÿº0‰T$‹½ðþÿÿ‹¼‰L$‰D$‰|$‰4$èüÿÿÿéùÿÿ³ìº'}¼‰t$‹³‰|$»N‰T$‰Ìþÿÿ‰L$ ‰|$‰4$èüÿÿÿ‰|$‹Ìþÿÿ¸)‰D$“E¸‰T$‰L$ ‰D$‰4$èüÿÿÿé¾úÿÿƒ½4ÿÿÿŽLýÿÿ³=‹èþÿÿ¿‰t$‹³‹Eˆ‰|$~‰|$ ‰L$‰D$‰4$èüÿÿÿ‰|$ ‹Hÿÿÿº!‰T$‹½ÿÿÿƒ\‰D$E¸TÏø‰T$‰…èþÿÿ‰D$‰4$èüÿÿÿéÎüÿÿ‹•ÿÿÿ‹½Hÿÿÿ‹µPÿÿÿ‹ôþÿÿDúø‰D$ Dòø‹•dÿÿÿ‰L$‰L$‰D$‰$èüÿÿÿéÉûÿÿ‹…äþÿÿ¹¿‰L$ ³‰|$‰t$‰$èüÿÿÿ…À…1‹u¸Nˆ\üÿÿ‹…dÿÿÿ‹U°‹½<ÿÿÿ‹Áâ@ÿÿÿ‹ÿÿÿ‰•Àþÿÿ‹…@ÿÿÿTùøLÁðv¼'ÝÜ9Ý‹½ÀþÿÿƒÂùNyìéüÿÿ‹ÿÿÿ‹•<ÿÿÿ‹µôþÿÿ‹…Dÿÿÿ|Ñø‹•dÿÿÿ‰t$‰t$tÁø‰|$ ¿‰$‰t$èüÿÿÿ‰|$ ‹•äþÿÿ¸‰D$‹‰L$‰$èüÿÿÿ…À…ö‹dÿÿÿ‹Jx"Ùƒ‹…|ÿÿÿ݉ðÙÁÜ0ØÁ݃ÀJyòÝØÝØ‹}ˆ‹µôþÿÿ‹•Dÿÿÿ‰|$ ‹½ÿÿÿ‹èþÿÿ‰t$‰t$t×ø‰t$‰ $èüÿÿÿ‰t$ ‹•<ÿÿÿ¸‰D$E¸L×ø‰L$‹ôþÿÿ»‰…èþÿÿ‰D$‰L$‰<$èüÿÿÿ‹U”‹2…ö„݉<$‹•@ÿÿÿ¸‰D$‹ÿÿÿu°‰t$‹µdÿÿÿDÑø‰D$‹Uˆ‹èþÿÿ‰t$‹E”‰T$ ‰L$‰D$éÂùÿÿ‹…ÿÿÿ‹‹½Hÿÿÿ‰ôþÿÿ‹•Lÿÿÿ‰L$tøø<Љ|$‹½dÿÿÿ‰t$ ‰L$‹MÔ‰ $H‰EÔèüÿÿÿ‰<$‹ÿÿÿ‹•Dÿÿÿ‹…ôþÿÿTÑø‰D$‰•ÿÿÿ‰T$ ‹•8ÿÿÿ‰D$‹…LÿÿÿÐTÁø‰T$èüÿÿÿ‰t$ ‹<ÿÿÿ¸‰D$ ‹½ÿÿÿU´‰T$‹•@ÿÿÿ³}‰4$DÏø‹ÿÿÿ‰…ÿÿÿ}°‰D$DÑø‹•dÿÿÿ‰D$‹…ÿÿÿ‰|$‰T$‰D$èüÿÿÿ‹M´…É„/‹µTÿÿÿÇøÿÿÿé¡ñÿÿ³ˆ‹Mˆ¿+‰t$‹³‹•èþÿÿ‰|$~‰|$ ‰L$‰T$‰4$èüÿÿÿ‰|$ ‹•Hÿÿÿ¸7‰D$‹½ÿÿÿ‹´‰L$M¸D×ø‰D$‰èþÿÿ‰L$éüÿÿ‹•ÿÿÿ‹µôþÿÿ‹Hÿÿÿ‹…ôþÿÿ‰t$tÊø‹Pÿÿÿ‰D$‰t$ DÊø‹dÿÿÿ‰D$‰ $èüÿÿÿÝ…ÿÿÿ‰t$‹dÿÿÿUÈÜ} ‰T$‹…ôþÿÿ‰ $‰D$ Ý]Èèüÿÿÿ‰t$‹•èþÿÿ¸‰D$‹uˆ‹ôþÿÿ‰T$‰t$ ‰L$‰<$èüÿÿÿé÷ÿÿƒ½4ÿÿÿ­‹µÿÿÿ…ötb‹½dÿÿÿ¹‰$ÿÿÿ‹‰• ÿÿÿJu,ëD‹• ÿÿÿ‹MŒ‹|‘ü…ÿ…óJ‰• ÿÿÿ‹½ ÿÿÿ9½$ÿÿÿ}‹½$ÿÿÿ‹uŒ‹D¾ü…ÀtÅG‰½$ÿÿÿë؃½4ÿÿÿé‹uˆ‹Dÿÿÿ‹•ÿÿÿ‰t$ ‹½ôþÿÿu¸‰µèþÿÿDÊø‰|$‰|$‰D$‰4$é/öÿÿ‹½äþÿÿ¸¹‰D$ “‰L$‰T$‰<$èüÿÿÿ…À…‹½dÿÿÿ‹JˆöûÿÿÙƒ‰ð‹|ÿÿÿÝÝÙÁØÉÙÉØãÞù݃ÀJyìéÉûÿÿ‹•äþÿÿƒ‡¿‰|$ ¾‰t$‰D$‰$èüÿÿÿ…À„úÿÿ‹U”‹2…ö„ööÿÿ‹äþÿÿƒ¾‰t$ ¿‰|$‰D$‰ $èüÿÿÿ…À…Äöÿÿ‹u¸NˆºöÿÿÙƒ‹½dÿÿÿ‹U°‹<ÿÿÿ‹Áâ…@ÿÿÿ‹…ÿÿÿ‰•Àþÿÿ‹½@ÿÿÿTÈøLøðÝØáÜ9Ý‹…ÀþÿÿƒÂÁNyêÝØécöÿÿt&‹µHÿÿÿ}´‹ÿÿÿ‰|$‹•dÿÿÿDñø‰…ÿÿÿ‹µ<ÿÿÿ‰D$‹ ‹•@ÿÿÿ΋ÿÿÿDñø‰D$u°‹…èþÿÿ‰µøþÿÿ‰t$ tÑø‹•dÿÿÿ‰t$‰D$‰$èüÿÿÿ‰|$,‹•tÿÿÿ¹ ‰L$4¸‹üþÿÿ‰D$0‹‹•\ÿÿÿÁ‹dÿÿÿ‰D$(‹…`ÿÿÿ‰T$$‰D$ ‹‰t$‹…<ÿÿÿu¸‰t$‹øþÿÿЉL$‹•ÿÿÿ‹ë‰L$DÂø‹•tÿÿÿ‰D$‹…dÿÿÿ‰T$‰D$ ƒö‰$èüÿÿÿ‰µèþÿÿ‹M€º‰T$‹E„‹•\ÿÿÿ‰L$‹`ÿÿÿ‰D$‹…tÿÿÿ‰T$“û‰L$ ‰t$‰D$‰$èüÿÿÿ‹dÿÿÿ‹‰Áƒéx‹•ÿÿÿÇÇBƒÂIyí‹Hÿÿÿ1ÒÈ‹ÿÿÿ‰TÁðºð?‰TÁôº ‰|$,}¨‰T$4‹•Hÿÿÿ‰|$(‹½dÿÿÿ¸‰D$0DÑø‰|$$‰D$ ‹‰t$‹…<ÿÿÿ‹½@ÿÿÿ‹µôþÿÿÐTÁø‰T$‹…øþÿÿ‹•ÿÿÿ‰t$ ‰D$‹…dÿÿÿLúø‰L$“þ»‰D$‰T$‰<$èüÿÿÿéhóÿÿ‹µ$ÿÿÿ‹•Dÿÿÿ‹ ÿÿÿ‹…Dÿÿÿò‹µÿÿÿÈÝDÖðÝDÆðÙÉÝU¨ÙÉÝ\ÖðÝ\Æð‹½ôþÿÿ‹<ÿÿÿ‹•@ÿÿÿ‰|$|Îø‹µôþÿÿ‰|$ ‹dÿÿÿ‰t$‹µ$ÿÿÿ‹‰ $N¯ÆЋ•ÿÿÿDÂø‰D$èüÿÿÿ‹•ôþÿÿ‹@ÿÿÿ‰T$‹•dÿÿÿ‹‰$¯ð΋ÿÿÿtñø‰t$ ‹µôþÿÿ‰t$‹µ ÿÿÿN¯Æ…@ÿÿÿDÁø‰D$èüÿÿÿ‹•ôþÿÿ‹@ÿÿÿ‰T$‹•dÿÿÿ‹‰|$‰$¯ÆÈ‹ÿÿÿDÁø‰D$ ‹…ôþÿÿ‰D$èüÿÿÿÿ…$ÿÿÿ‰µ ÿÿÿéâúÿÿ“ ‹Dÿÿÿ¿'‰T$‹“‹µÿÿÿ‰|$B|Îø‰D$ ‹…dÿÿÿ‰|$‰$‰D$èüÿÿÿéÌúÿÿ‰|$‹ÿÿÿ‹…ôþÿÿ‹µ@ÿÿÿ‹•ÿÿÿ‰L$ ‹dÿÿÿ‰D$‹9‰ $þDòð‰D$³4èüÿÿÿ‰t$‹³¿-‰|$‹ÿÿÿ‹…dÿÿÿ‰4$~‰L$‰|$ ‰D$èüÿÿÿ‰|$ º0‹…ÿÿÿ‰T$‹•dÿÿÿ‹d‰L$‰D$‰T$‰4$èüÿÿÿé¡ùÿÿ‹äþÿÿºƒ‰T$¿‰|$ ‰D$‰ $èüÿÿÿ…À…Ç‹…dÿÿÿ‹IˆfñÿÿÙƒ‰ð‹•|ÿÿÿ‹µ<ÿÿÿ‹½ÿÿÿÝT÷øÝÝÙɃÂÙáÙÉØãÙÉØÊÙÉØÈÞù݃ÀIyßÝØÝØéñÿÿ‹•äþÿÿ¹ƒ‡‰L$ ¿‰|$‰D$‰$èüÿÿÿ…À…Îõÿÿ‹…dÿÿÿ‹Jˆ¿õÿÿÙƒ‰ð‹½|ÿÿÿÝÝÙÀØÃÙÉØãÙÉØÊÞñ݃ÀJyèéŽõÿÿ‹äþÿÿºƒ‡‰T$ ¿‰|$‰D$‰ $èüÿÿÿ…À…|ðÿÿ‹…dÿÿÿ‹IˆmðÿÿÙƒ‰ð‹½ÿÿÿ‹µ<ÿÿÿT÷ø݃ÂÝØñÙÉØâÞÉÙá݃ÀIyçÝØé5ðÿÿLMSMLASABEEpsilon-MachineREGULRSHIFTI_seupd: Ritz values passed in from _SAUPD._seupd: Ritz estimates passed in from _SAUPD.BUCKLECAYLEY_seupd: Ritz values after calling _SGETS._seupd: Ritz value indices after calling _SGETS._seupd: Number of specified eigenvalues_seupd: Number of "converged" eigenvalues_seupd: Converged Ritz values_seupd: Associated Ritz estimatesIdentity_seupd: Untransformed converged Ritz values_seupd: Ritz estimates of the untransformed Ritz valuesNotransposeRightAllTransposeLeft_seupd: The eigenvalues of H--reordered_seupd: NCV Ritz values of the final H matrix_seupd: last row of the eigenvector matrix for HUUUUUUå?ð?€?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst8.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ Ô#è%à+à4à0 ¼'>ä”FxSˆ`‡”—”#· Øà ¸"ñÿ  #(   <B HN  T[c z `òÿ—¥©±¸¿ÆÍÕÛâéñù  |òÿdseupd.ft0.0t1.1t2.2t3.3t4.4t5.5__g77_forceload_0.6.LC10.LC11.LC33.LC22dswap_dseupd___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_debug_s_cmpdlamch_powdsgets_s_copydnrm2_dvout_dcopy_dsesrt_dger_dscal_ivout_dsortr_dsteqr_dgeqr2_dorm2r_dlacpy_timing_ ¸F Vœ ¶Õ â - :ï  "P£ ³  @ W › ±!Å Úÿ" <"J #¯#º â0 K $Š ø D x ¥ %¾ ×  B \ &€ Ò ç  "' ; "F X b  '˜ ¯ 'Ç Ü ú " : "} #œ ¬ X#q }– é# )( Ð##B )£ µÖ"õ W#†&¶(• ¥Â ñ 0 Nf .*ž Ä Ì+ ,Ý ã ó+ƒ#Ø##0 Ep"´ ¹#Ãï" ""8 Qn à Üù 1 Jg dsesrt.o/ 1189291778 1000 1000 100644 2276 ` ELFø4( U‰åWVSƒì\‹M ‹EèüÿÿÿËU‹}‰Mð‹M‰Eì‹E ‰Uè‹u‰MÔ‹‰}ä‹}ì‰U຋‰T$ ‰4$‰ÈÁè<¹ƒ‰L$Ñÿ‰D$èüÿÿÿ…À…Ï…ÿ„­‰}Ü‹Uì‰þ÷Ö2‰u؈‡ƒ‰EЋuÜë )þ…öx^‹Uè >ÝòÝÊÝáßàžvlÝò‹EðÝÊ‹…ÒtØ‹Eà‹UЯÁ‰T$‹UÔ Â‰L$ ‹Mà‹EЯÎ)þ‰D$Ê‹Mä‰D$‰ $èüÿÿÿ…öy¢ÿEÜÿMØy‚‰þÁî÷Ñÿ…ÿ…SÿÿÿƒÄ\[^_]ÃÝØÝØÿEÜÿM؉YÿÿÿëÕ‰4$º¸‰T$ ‹‰D$‰L$èüÿÿÿ…À…½…ÿt¶‰}´‹Mì‰þ÷Ö1‰üƒ‰EÈ‹u´´&)þ…öxj‹Uè >ÝòÝÊÙÁÙÁÙÉÙáÙÉÙáÚéßàžveÝòÝÊ‹Uð‹…ÀtÌ‹Eà‹UȯÁ‰T$‹UÔ Â‰L$ ‹Mà‹EȯÎ)þ‰D$Ê‹Mä‰D$‰ $èüÿÿÿ…öy–ÿE´ÿM̉yÿÿÿ‰þÁî÷ÑÿéIÿÿÿÝØÝØëà‰4$º¸‰T$ ‹‰D$‰L$èüÿÿÿ…À…«…ÿ„Éþÿÿ‰}°‹Mì‰þ÷Ö1‰uĈ€ƒ‰EÀ‹u°)þ…öxf‹Uè >ÝòÝÊÙÉÝáßàž†@ÙÉÝòÝÊ‹Uð‹…ÀtЋEà‹UÀ¯Á‰T$‹UÔ Â‰L$ ‹Mà‹EÀ¯Î)þ‰D$Ê‹Mä‰D$‰ $èüÿÿÿ…öyšÿE°ÿMÄy‰‰þÁî÷ÑÿéUÿÿÿ‰4$º¸‰T$ ‹‰D$‰L$èüÿÿÿ…À…úýÿÿ…ÿ„òýÿÿ‰}¬‹Mì‰þ÷Ö1‰u¼ˆ†ƒ‰E¸‹u¬)þ…öxl‹Uè >ÝòÝÊÙÁÙÁÙÉÙáÙÉÙáÙÉÚéßàžvvÝòÝÊ‹Uð‹…ÀtÊ‹Eà‹U¸¯Á‰T$‹UÔ Â‰L$ ‹Mà‹E¸¯Î)þ‰D$Ê‹Mä‰D$‰ $èüÿÿÿ…öy”ÿE¬ÿM¼yƒ‰þÁî÷ÑÿéOÿÿÿÝØÝØÿE°ÿMĉŽþÿÿéÿÿÿÝØÝØëÏSASMLALM‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@ÿ T %@+@0@8HELlP|P#s…  Qñÿ  ÿ.DJdsesrt.f.LC1dsesrt___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_cmpdswap_  ] l— Z gŽ C P{ é 'R Æcnaitr.o/ 1189291778 1000 1000 100644 10176 ` ELF`4( U‰åWVSì<‹U‹EèüÿÿÿËu‹}‰•|ÿÿÿ‹U(‰…xÿÿÿ‹E,‰u„‹M ‰½tÿÿÿ‹u ‰•Lÿÿÿ‹}0‰…hÿÿÿ‹U<‰M€‹M$‰µpÿÿÿ‹u4‰½@ÿÿÿ‹½hÿÿÿ‰•Hÿÿÿ‹E@‰lÿÿÿ‹M8‰µdÿÿÿ‹7‰`ÿÿÿ‰…\ÿÿÿ‰µXÿÿÿ‹dÿÿÿ‹‰•Tÿÿÿ‹ƒ…À…7‹M„‹1…ö„š‹»$…ÿ…¯‹ƒ(…À„6³“‰µüþÿÿ‰•ÿÿÿ‹}€¶‰ÁùƒøŒ‰EÀ)Á‰Â‰ÎNˆ2ÙƒMœ}˜ÙƒÙɉÿÿÿE”‰½ÿÿÿM‰…ÿÿÿ}Œ‰ ÿÿÿEЉ½$ÿÿÿ‹Ž‰…8ÿÿÿ}ˆ‰4ÿÿÿÙ0ÿÿÿÙ,ÿÿÿëCÝØÚéßàžr*Ù…0ÿÿÿ‹UÀ‹TÿÿÿBÿ¯ÁЋ•@ÿÿÿÙÂÙ…,ÿÿÿÙ\‹EÀ@N‰EÀ‰ÂˆŽ‹TÿÿÿBÿ¯Á‹@ÿÿÿЋTÁü‰Uœ‹•ÿÿÿ‰T$‹TÁø‹…ÿÿÿ‰U˜‰$èüÿÿÿÙPÿÿÿ‹UÀ‹…Tÿÿÿ‹MÀ¯ÂÈ‹@ÿÿÿ‹TÁ‰U”‹•ÿÿÿ‰T$‹Á‹• ÿÿÿ‰E‰$èüÿÿÿÙ]ìÙîÙEìØ…PÿÿÿÝáßàÝÙÙPÿÿÿžtb‹UÀ‹TÿÿÿBÿ¯Á‹@ÿÿÿЋTÁ‰UŒ‹•$ÿÿÿ‰T$‹Á‰Uˆ‰<$èüÿÿÿÙ]ìÙ…PÿÿÿØ‹TÙƒPÙEìÙÊÝáßàž‚ÉþÿÿÝÙéÄþÿÿzœ‹•|ÿÿÿ¸‰D$‹Hÿÿÿ‹‹•dÿÿÿÁ‹tÿÿÿ‰T$ ‹•xÿÿÿ‰D$‹…@ÿÿÿ‰D$‹‹ ‹•8ÿÿÿȉEЉT$‹…4ÿÿÿ‰$èüÿÿÿÙPÿÿÿé2ÿÿÿ‹“d³¿1Ù]¬M¨ƒ‰U¨‰t$‹³‰|$‰L$~‰|$ ‰D$‰4$èüÿÿÿ‰|$ ‹Áº‰L$‹‹D‰T$‹…TÿÿÿI‹•@ÿÿÿ¯ÈƒD<ʉ|$‰…øþÿÿ‰D$‰4$èüÿÿÿé[ôÿÿÝØ‹•|ÿÿÿEÄ¿‰|$(‰…(ÿÿÿ‹»D‰D$$‰T$ ‹XÿÿÿO‹µLÿÿÿ¯ù‹|ÿÿÿþ‹½lÿÿÿ‰D$‹•ÿÿÿ³‰L$‰T$‰µDÿÿÿ‰t$uÀ‰|$ »Ù‰t$‰t$‰<$èüÿÿÿ¸‰D$(‹•(ÿÿÿ‹ƒ0‰T$$‹•|ÿÿÿ‰T$ ‹HÿÿÿDÁø‰D$‹…ÿÿÿ‰T$‹•lÿÿÿ‰D$‹Dÿÿÿ‰T$ ‰t$‰L$‰t$‰<$èüÿÿÿé.ûÿÿ“‹»0‹µpÿÿÿ‰T$‹Hÿÿÿ‰T$ ‰t$Dùø‹|ÿÿÿ‰D$}܉<$‰L$èüÿÿÿ‹UàE´M°‰U´‰D$‹u܉u°‰ $èüÿÿÿÙ]ìÙEìÙúÙ]싽lÿÿÿÙEìÙé¬òÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹u€Ø« Ø@lÙXl¶é[òÿÿ³à¹(»D‰t$‹³‰L$V‰•ÿÿÿ‰|$»‰T$ ‰|$‰4$èüÿÿÿ¸)‹‰D$‹…lÿÿÿ‰L$‹•ÿÿÿ‰D$‰|$‰T$ ‰4$èüÿÿÿéõÿÿÿF¿‰»(‹½`ÿÿÿ‹u„‹“4‹ƒ0lj‰GÄ<[^_]Ë‹ÿA‹pÿÿÿ‹µ<ÿÿÿ‹»4‰t$‹•Hÿÿÿ‰t$‰L$Dúø‹½|ÿÿÿ‰D$ ‰<$èüÿÿÿ답üþÿÿ‹»0‹pÿÿÿ‰t$‹•Hÿÿÿ‰t$ uäDúø‰D$‹½|ÿÿÿ‰L$‰4$‰|$}¸èüÿÿÿ‹UèE¼‰U¼‰D$‹Mä‰M¸‰<$èüÿÿÿÙ]ìÙEìÙúÙ›défïÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹M€Ø« Ø@lÙXl¶éïÿÿ‹•pÿÿÿƒ‹µ|ÿÿÿ‰D$‰T$‰4$èüÿÿÿéúýÿÿ‹…üþÿÿ‹µpÿÿÿ‹|ÿÿÿ‰D$‰t$‰ $èüÿÿÿévÿÿÿÝØéôÿÿ‹³ÿF‹µpÿÿÿ‰|$‹Hÿÿÿ‰|$‹ƒ4‰t$‹½|ÿÿÿTÁø‰T$ ‰<$èüÿÿÿ‹•`ÿÿÿ‹‹4‹ƒ0‹u„‰ ‰BÇéÔøÿÿ³ ‰4$èüÿÿÿÙƒ‹ƒ‹M€Ø« Ø@lÙXl¶ðŸFS¤z¨Š¨#Ë“¸0, èÏñÿ  #(08@ I$R([,c0j4q8x<€@ˆDH—LŸP©T°X¸\Á`ËdÔ  éî ôùÿ  ¦ *@GO |òÿW^ `òÿelt{ƒ‹“›£ª±¹ÀÈcnaitr.ft0.0t1.1t2.2t3.3t4.4t5.5first.6orth1.7orth2.8rstart.9step3.10step4.11ierr.12ipj.13irj.14ivj.15iter.16itry.17j.18msglvl.19ovfl.20smlnum.21ulp.22unfl.23betaj.24rnorm1.25wnorm.26__g77_forceload_0.27.LC5.LC15.LC8.LC17.LC9cscal_cnaitr___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_cgemv_arscnd_timing_caxpy_debug_ivout_cgetv0_ccopy_slamch_slabad_csscal_slapy2_clanhs_svout_cvout_clascl_cdotc_scnrm2_cmout_. /­ È Ö ä &ê  7 Q "h | " "¨ ´0Ó  " "006 J h p1{ ‰1± Í 'Ó è2ð ù    ") &K U "w "‘0ª Ð "ä "0 + T3Z ` h1” ž ­ "³ ½4à &Þ5ä ñ 'ý  ( 6 D (J V b x ~ ‡ Œ1’ ˜2¤ ¶ Á Ñ õ û    "4$ &?5E O2U ` (i u ‰  6 , 6 B H Y1_ e2n … 1“ ›2¡ ­ &¹ Å ç ó71# W7b l1r4… ‘ ™ ¥ · ¾ Ì Ô Ú à ÷ "ý   8 "6 F "N S 9^ "j 8| † Ž ” ¥ Ù 7ò ø & A 7G o Ÿ :« Ï :Õ 2à æ ð 1ü  I 7U [ a ‡ ± 7 Ê 1Ð ß  "$ "V "ð ;2 ;… ;” š <# ) ": )G4b=l "{ • ®>Ó   *) "9?N œ?§ &­ â@;! )1/ 52> R "] g4~ &Ž5™ "Á=Ô ã é 2 B7P ˆ@£;± ¼ Ä1Ê Ð2Ù ó & A0AB2_ y7… ‹ ¤ ¬1² ¸2Á Ø &Þ @1;? J W "l4³B¾2É Ð î "ô "@ "I ^ )v=‡ &A,cnapps.o/ 1189291779 1000 1000 100644 8084 ` ELF\4( U‰åWVSìì‹M‹u èüÿÿÿËU‹}‰Mˆ‹M‰u„‹u ‰U€‹E‰½àþÿÿ‹U$‰xÿÿÿ‹},‰µ4ÿÿÿ‹u8‰…|ÿÿÿ‹E(‰•tÿÿÿ‹•xÿÿÿ‰½ðþÿÿ‹M4‰µäþÿÿ‹}0‰…pÿÿÿ‹‰lÿÿÿ‹tÿÿÿ‰…hÿÿÿ‹1‰µdÿÿÿ‹ƒ‹…À‰•`ÿÿÿ…㳉4$èüÿÿÿ‹³‹U€‹M„‹FT‰…\ÿÿÿ‹‹‰|$‹»‰½Äþÿÿк‰E¨‹…ðþÿÿ‰T$U¨‰D$ƒ‰|$‰Àþÿÿ‰L$ ‰•Üþÿÿ‰T$‰T$‰$èüÿÿÿ‹}€‹…À„ ÇE¤»H‰½¼þÿÿ‰…XÿÿÿˆÙƒ‰µPÿÿÿF‹‰…PþÿÿuäU¤Ùtþÿÿ».‰Lÿÿÿ‹Pþÿÿ‰µ˜þÿÿ‹µPÿÿÿ‰•Øþÿÿ“D‰½Tÿÿÿƒn‰Œþÿÿ}艕þÿÿ‹•Øþÿÿ‰µ„þÿÿ‹µŒþÿÿ‰½Hÿÿÿ‹o‰…”þÿÿ} ‰•|þÿÿƒŒ‰½ˆþÿÿ“·‰…€þÿÿ»Ô‰xþÿÿEœ‰½,ÿÿÿM˜‰µ(ÿÿÿ}ĉ…Ôþÿÿủ•$ÿÿÿE”‰ÐþÿÿUÔ‰½lþÿÿMÜÙƒ‰µhþÿÿ‰…dþÿÿ‰•`þÿÿÙpþÿÿÙ…tþÿÿ‰\þÿÿÙXþÿÿÙ…pþÿÿÙTþÿÿƒ½\ÿÿÿ‹E¤‹|ÿÿÿ‹TÁø‹tÁü‰Uè‰uìaÇEœ‹M¨‹uœ‰Ï)÷‰u ‰þNˆ ‹þÿÿ‹…Œþÿÿ‹•„þÿÿ‰Dÿÿÿ‹€þÿÿ‹½”þÿÿ‰…@ÿÿÿ‹…xþÿÿ‰•<ÿÿÿ‰8ÿÿÿ‰…0ÿÿÿëÝÚÙÉÙÉÚéßàžƒªJN‰M ˆ¤‹U ‹dÿÿÿBÿ¯Á‹4ÿÿÿÐÙDÁøÙDÁüÙÉ‹…dÿÿÿÙáÙÉÙá¯ÂÞÁÐÙÁÙDÁÙÉÙáÙÉÙáÞÁÙîÙÊÞÁÝáßàÝÙž„÷Ùƒ ‹dÿÿÿBÿÞɯÁ‹4ÿÿÿÙƒÐÙÁÙÊÝáßàÙÊžÙá‚TÿÿÿÝÙÙÉÚéßàž‚Vÿÿÿ‹½\ÿÿÿ…ÿŽÈ‹½ˆþÿÿº*‹Dÿÿÿ‰T$‹µ<ÿÿÿ‹…@ÿÿÿ‰|$‹½¼þÿÿ‰L$‰4$‰|$‰D$ èüÿÿÿ‰|$‹8ÿÿÿº+‰T$‹µ|þÿÿ‹½<ÿÿÿ‰L$‹…@ÿÿÿ‰t$‰<$‰D$ èüÿÿÿ‰<$º‹…@ÿÿÿ‰T$‹U ‹µdÿÿÿ‰D$ ‹0ÿÿÿBÿ¯Æ‹µ¼þÿÿ‰L$‹4ÿÿÿЉt$Á‰T$èüÿÿÿ‹U Ù…tþÿÿ‰U˜‹…dÿÿÿzÿ‹µ4ÿÿÿ¯ø×ÙþÙ…pþÿÿÙ\þƒ½\ÿÿÿŽ ‹µ(ÿÿÿ¹‹½Ôþÿÿ‰L$‹…,ÿÿÿ‰t$ ‹µ¼þÿÿ‰|$‹½Pÿÿÿ‰D$‰t$‰<$èüÿÿÿ‰t$º‹$ÿÿÿ‰T$‹…(ÿÿÿ‹•Ðþÿÿ‰L$‰D$ ‰T$‰<$èüÿÿÿ‹}œ‹u˜9÷…›N‰Mœ‹M¨9ÎŒPýÿÿÿE¤ÿXÿÿÿ‰ýÿÿ‹U„¿‹ ‰ÎN‰µÿÿÿˆU¼E䉕üþÿÿU¬‰…øþÿÿ‹…ðþÿÿ‰•´þÿÿ‹•`ÿÿÿM‰ÌþÿÿM´uŒ‰¸þÿÿÁâ‹4ÿÿÿ‰µÈþÿÿÐu°‰…°þÿÿ‹…dÿÿÿÙôþÿÿÁà1ö‰µ þÿÿÁ‰¨þÿÿ1ɉœþÿÿ‰…¤þÿÿ‰•¬þÿÿé6ÙÂØôÜËÙÀØÊÙÌÞÅÙÂÞÉÙËÞâÞÂØòÙÉÞòÙU¸‹µœþÿÿ‹•dÿÿÿÙàÙÉ‹…tÿÿÿ‹4ÿÿÿÙU´¯Ö‰D$ Ù]¼Ù]À4:ñ‰D$‹E¨‹•üþÿÿ‹øþÿÿ)ø@‰T$‰ $‰Eäèüÿÿÿ‹•¼þÿÿ‹…¨þÿÿ‹¸þÿÿ‰T$ ‹U¨‰D$G9ЉL$~‰Ð‰E°‹•ôþÿÿ‰$èüÿÿÿ‹¼þÿÿ‹…°þÿÿ‹•¸þÿÿ‰L$ ‹M€‰T$‹U¨‰D$‹ø@9Ð~‰Ð‰E¬‹´þÿÿ‰ $èüÿÿÿ‹…4ÿÿÿÙîÙTðÿ…œþÿÿG‹…dÿÿÿ… þÿÿ‹•¤þÿÿ‹µ¬þÿÿ•¨þÿÿµ°þÿÿÿÿÿÿˆØ ‹ þÿÿ‹•4ÿÿÿùÙÊÙÉÝáßàÝÙžw‹µ4ÿÿÿÙDÎÝéßàžztšÝØ‹•dÿÿÿ‹µœþÿÿ‹Ìþÿÿ¯ò‹•4ÿÿÿþ‹Dò‰L$‰E‹ò‹•Èþÿÿ‰EŒ‰$èüÿÿÿÙ]ð‹4ÿÿÿÙîÙEðÙñÙDñÙÂÙáÙÌÝäßàÝÜž‡5þÿÿÙÃØóÙÁØÉÙÍØÉÙÍØÃÙËÞÉÙÌÞÃÞãØñÙÊÞñé.þÿÿ‹u„‹‹…dÿÿÿqÿ‹½4ÿÿÿ¯ð1Ù×Úéßàž‡@ ÇE ‰ÎNˆøƒó}¬‰…Lþÿÿë‹U„‹ ‰|$º‹…¼þÿÿ‰T$,‹•äþÿÿ‰D$(‹…Àþÿÿ‰T$$‹•¼þÿÿ‰D$ ‹…`ÿÿÿ‰T$‹U )ѯÁ‹ðþÿÿÁ‰D$‹xÿÿÿ‹…àþÿÿ‰L$‹Äþÿÿ‰D$‹E¨‰L$ ‹Lþÿÿ)ЋUˆ@‰ $‰E¬‰T$èüÿÿÿ‹…¼þÿÿ‹U ‹hÿÿÿ‰D$‹E¨)ЯÁ‹•àþÿÿ ‰L$ ‹•¼þÿÿ‹…äþÿÿ‹Mˆ‰T$‰D$‰ $èüÿÿÿÿE N‰ÿÿÿ‹}„‹¾‹…àþÿÿ‹½xÿÿÿ‰t$‹u¨‹•àþÿÿ‰D$)΋hÿÿÿ‰|$‹E„‰|$¯ñ‹Mˆ‰D$<ò“ô‰|$ ‰L$‰$èüÿÿÿ‹u„Ùdÿÿÿ‹‹µ4ÿÿÿBÿ¯Ç ÙÎÚéßàž‡‹ ‹`ÿÿÿJ‹½¼þÿÿ‹…ðþÿÿ¯Ñ‹M¨‰|$ ‹½pÿÿÿ4ЋUˆDÎø‰|$‰D$‰$èüÿÿÿ‹u„Ùî‹dÿÿÿ‹‹µ4ÿÿÿBÿ¯Á ÙÎÚéßàž‡ß ƒ½\ÿÿÿŽ¾(‹M„»ø‰t$‹³‹•`ÿÿÿ‰|$~‰|$ ‹‹ðþÿÿ‰4$H¯ÂÁ‹M¨DÊø‰D$‹•¼þÿÿ‰T$èüÿÿÿ‰|$ ‹U„¹%‰L$ƒ ‹dÿÿÿ‰D$‹‰4$Pÿ¯Ñ‹4ÿÿÿЋ•¼þÿÿÁ‰D$‰T$èüÿÿÿ‰|$ ¹-‹U„‰L$‹¼þÿÿƒH‰D$‰T$‰L$‰4$èüÿÿÿƒ½\ÿÿÿ~>‰|$º6ƒx‰T$‹tÿÿÿ‹•4ÿÿÿ‰D$‹E„‰L$‰T$ ‰D$‰D$‰4$èüÿÿÿ³‰4$èüÿÿÿÙƒ‹»Ø«ØG`Ù_`Äì[^_]ÊøÿÿÝ؉L$‹…lÿÿÿº‰T$‹•tÿÿÿ‹M¤‰D$‹E¨‰T$ ‹•˜þÿÿ)ȉ<$@‰T$‰EäèüÿÿÿÙ]ð‹U ÙEðé´÷ÿÿ‹M¨‰M˜ƒ½\ÿÿÿóøÿÿ‹}œ‹u˜9÷„eùÿÿ‹U„9:ŒZùÿÿÙEè‹dÿÿÿGÿÙEìÙÉ‹•4ÿÿÿ¯Áø‹LÂØlÂøÙÉØlÂüÙÂÙʉð)øÙ]ÜHÙ]àÙ]Ô‰M؉} ‰… ÿÿÿt&ˆùÿÿ‹lþÿÿ‹…hþÿÿ‹•dþÿÿ‰L$‹µ`þÿÿ‹½\þÿÿ‰D$ ‰T$‰t$‰<$èüÿÿÿ‹M ;Mœ~5‹½dÿÿÿqþ‹EÄ‹Uȯ÷‹½4ÿÿÿΉD÷ø‰T÷üÙ…XþÿÿÙ÷Ù…TþÿÿÙ\÷‹E¨‰Î‰Â)ÊyéD´&‹M ÙE”‹½dÿÿÿFÿÙEÌFÙEЯÇÙÁÈ‹4ÿÿÿJÙDÁøÙÿÿÿÙDÁüÙHþÿÿÙ…ÿÿÿØÌÙÿÿÿÙîØHþÿÿØ­ÿÿÿÙÿÿÿÙ…HþÿÿØÌÙÿÿÿÙîØÿÿÿØ…ÿÿÿÙÿÿÿÙÁÙDÁÙÁÙÁØÍÙÉØÎÙÌØÊÙÌÞáÙÂØÍÙÉØ…ÿÿÿÙÍÙàÙÉÞÄÙ…ÿÿÿÙÌØ…ÿÿÿÙÍÙ•ÿÿÿÙÌØÎÙÌÙ]´ÙÆØËÙÍÙ•ÿÿÿÙÏØÊÙÏÙ]¸ÙîÞÊÙÍØHþÿÿÙÌÞáÙîÞÊÙ…HþÿÿØÍÙÎÞÂÙÌØÿÿÿÙÊÞåÙËÞäÜÁÙÿÿÿÞéÙÉÙÁÙ\ÁÙ…ÿÿÿÙ\ÁøÙ…ÿÿÿÙ\Áü‰Æþÿÿ‹M ‹U˜A9Ð~‰Ð‰Æ¿Nyé:‹M ÙE”‹•dÿÿÿAÿÙEÐÙEÌÙɯ‹•4ÿÿÿÙàÙÁøÙDÂüÙDÂøÙÉ‹•dÿÿÿÙDþÿÿÙÄØɯы4ÿÿÿúÙÿÿÿGÙîØDþÿÿNØ­ÿÿÿÙÿÿÿÙ…DþÿÿØÍÙ ÿÿÿÙîØÉØ… ÿÿÿÙ ÿÿÿÙÂÙDÑøÙDÑüÙÌØÉÙÊØÌÙÍØÉÙÊÞåÙÅÙÍØ…ÿÿÿÙÍØÌÙÍÙ•ÿÿÿÙÍÞÂÙÆÙÊØ… ÿÿÿÙÊØÉÙÏØÌÙÊÙ• ÿÿÿÙ]¸ÙîÞÌÙÌÙ]´ÙÁØÍÙÊØMÐÙÎÞãÙîÙÍØDþÿÿÙÌÞÍÙ…DþÿÿØMÐÙÉÞÅÙÍÞÃÞäÙÊÞáÙÉÞâÙ\ÑüÙ\ÑøÙ…ÿÿÿÙ\ÁøÙ… ÿÿÿÙ\Áü‰Éþÿÿ‹M ‹u¤‰È‹U¨ð9Ð~‰Ð‰Æ¿Nyé:‹M ÙE”‹•`ÿÿÿAÿÙEÐÙEÌÙɯ‹•ðþÿÿÙàÙÁøÙDÂüÙDÂøÙÉ‹•`ÿÿÿÙ@þÿÿÙÄØɯыðþÿÿúÙÿÿÿGÙîØ@þÿÿNØ­ÿÿÿÙÿÿÿÙ…@þÿÿØÍÙÿÿÿÙîØÉØ…ÿÿÿÙÿÿÿÙÂÙDÑøÙDÑüÙÌØÉÙÊØÌÙÍØÉÙÊÞåÙÅÙÍØ…ÿÿÿÙÍØÌÙÍÙ•ÿÿÿÙÍÞÂÙÆÙÊØ…ÿÿÿÙÊØÉÙÏØÌÙÊÙ•ÿÿÿÙ]¸ÙîÞÌÙÌÙ]´ÙÁØÍÙÊØMÐÙÎÞãÙîÙÍØ@þÿÿÙÌÞÍÙ…@þÿÿØMÐÙÉÞÅÙÍÞÃÞäÙÊÞáÙÉÞâÙ\ÑüÙ\ÑøÙ…ÿÿÿÙ\ÁøÙ…ÿÿÿÙ\Áü‰Éþÿÿ‹M ‹u˜~ÿ9Ï~/‹½dÿÿÿAÿ¯Ç‹½4ÿÿÿÈ‹ljUÜ‹TljUà‹TÇ‹DÇ ‰UÔ‰EØÿ ÿÿÿA‰E é;ûÿÿ‹½Tÿÿÿº‹Øþÿÿ‰T$‹µPÿÿÿ‹…¼þÿÿ‰|$‹½Pþÿÿ‰L$‰4$‰|$ ‰D$èüÿÿÿ‰|$ ‹Lÿÿÿº‰T$‹…Hÿÿÿ‹µ¼þÿÿ‰L$‹½Pÿÿÿ‰D$‰t$‰<$èüÿÿÿé"ñÿÿ¹ ³®‰L$‰4$³ºèüÿÿÿÙ]ðÙîÙÀÙEð“ƒ$Ùƒ ÙʉT$Øñ‰$ÜËÞÊÙ“$ÞÂ؃ÞñÙ›èüÿÿÿ‰4$¹ ‰L$èüÿÿÿÙ]ð‹Uˆ1ÀÙEð‰ƒÛÙÉÙ“ ÞùØ‹$Ù›é{îÿÿ‹}„‹ÇE ‰ÎNˆÒõÿÿÙƒ»nÙìþÿÿÙƒÙèþÿÿëKÝØ‹…4ÿÿÿÙÈÙÉÚéßàžr*Ù…ìþÿÿ‹dÿÿÿBÿ¯ÁЋ•4ÿÿÿÙÂÙ…èþÿÿÙ\‹U BN‰E ˆbõÿÿ‹U ‹dÿÿÿBÿ¯Á‹4ÿÿÿÐÙDÁøÙDÁüÙÉ‹…dÿÿÿÙáÙÉÙá¯ÂÞÁÐÙÁÙDÁÙÉÙáÙÉÙáÞÁÞÁÝáßàžt3Ùƒ ‹dÿÿÿBÿÙƒÙÉÞÊÙɯÁ Ýáßàž‚;ÿÿÿÝÙé6ÿÿÿzËÝØÝ؉<$‹•lÿÿÿ¸‰D$‹tÿÿÿ‹…4ÿÿÿ‰T$‹U„‰L$ ‰D$‰T$èüÿÿÿÙ]ð‹U ÙîÙEð넺‹uˆ‹½äþÿÿ‰T$,‹•¼þÿÿ‰T$(‹‰T$‹•ðþÿÿ4ljt$$‹…`ÿÿÿ‹½Àþÿÿ¯Á‹xÿÿÿ‰|$ ‹½àþÿÿ4‰t$‹…Äþÿÿ‹µÜþÿÿ‰L$‹Uˆ‹ó‰|$‰ $‰D$ ‰t$‰T$èüÿÿÿ‹}„‹é0ôÿÿ‰|$‹…hÿÿÿ‹µ¼þÿÿ‹½àþÿÿ¯Ð‹…4ÿÿÿ‰t$‰t$ 4׋Uˆ‰t$4ȉt$‰$èüÿÿÿéÜõÿÿ‹…hÿÿÿ‹µàþÿÿ‹¼þÿÿ¯Â‹•äþÿÿ‰L$‰L$<Ɖ|$ ‹}ˆ‹7‰<$ò‰D$èüÿÿÿ‹M„‹é-õÿÿÙîé—ýÿÿ€?All_napps: Value of the shift _napps: shift number._napps: matrix splitting at row/column no.1_napps: off diagonal element._napps: matrix splitting with shift number._napps: End of current block _napps: Start of current block NA_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}_napps: betak = e_{kev+1}^T*H*e_{kev}_napps: Order of the final Hessenberg matrix _napps: updated Hessenberg matrix H for next iterationsafe minimumprecision‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@¢ ˆ %ä+è(0èÃ8¬E°l´|´#×…d   ñÿ  #(07@ F$N S¢[rˆ `òÿ—Ÿ¦­´¼ÃÊÒÙ |òÿáéñùcnapps.ft0.0t1.1t2.2t3.3t4.4t5.5first.6ovfl.7smlnum.8ulp.9unfl.10.LC7cnapps___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_claset_ivout_cvout_cscal_slapy2_cgemv_ccopy_clacpy_cmout_timing_clanhs_clartg_slamch_slabad_caxpy_ › ± ¹¿Ü â   -G ` o ‡ « · ä ù   V  § RŸKšÕÅP ì 3 !Š š " F P  £ Ö ò   M #S [ a g $m Å %ˆ &P‰™ ¦ «'» Á Ç Ü ä ì ñ('  % + K Q ]   m%è  J)!cnaup2.o/ 1189291779 1000 1000 100644 10232 ` ELF¼4( U‰åWVSì\‹u‹U èüÿÿÿËM‹}‰u˜‹E‰U”‹u‰M‹U ‰}Œ‹M$‰Eˆ‹}(‰u„‹E0‰U€‹u4‰|ÿÿÿ‹U8‰½xÿÿÿ‹M<‰…tÿÿÿ‹}@‰µpÿÿÿ‹ED‰•lÿÿÿ‰hÿÿÿ‰½dÿÿÿ‰…`ÿÿÿ‹UL‹}T‹uH‹EX‰•8ÿÿÿ‹U`‰½Xÿÿÿ‹}˜‰µ<ÿÿÿ‹MP‰…@ÿÿÿ‹u\‰•4ÿÿÿ‹‰\ÿÿÿ‹Md…À‰µTÿÿÿ‹uh‰Pÿÿÿ‰µLÿÿÿ„Q‹ƒ…À…r‹³$»H…ö„·‹…Lÿÿÿº¹‰“$‹•Tÿÿÿ‰L$<‹`ÿÿÿ‰D$8‹µ4ÿÿÿ‰T$0‹…dÿÿÿ‰L$,‹•lÿÿÿ‰|$‹|ÿÿÿ‰t$4‹µhÿÿÿ‰D$(‹…xÿÿÿ‰t$$‹u„‰T$ ‹Uˆ‰L$‹M‰D$‹E”‰t$‹u˜‰T$ ‰L$‰D$‰4$èüÿÿÿ‹U˜ƒ:c„‚Ä\[^_]ô&‹ƒ(…À„2‹•tÿÿÿ‹1öH‰³(t-‹‹E„‰L$‹•<ÿÿÿ‰L$‰T$ ‹½@ÿÿÿ‰$‰|$èüÿÿÿƒ»4‹4ÿÿÿ‹…Xÿÿÿ‹•\ÿÿÿ‰L$0‹½|ÿÿÿ‹µ@ÿÿÿ‰D$(‹`ÿÿÿ‹…hÿÿÿ‰t$,‹µdÿÿÿ‰T$$‹•lÿÿÿ‰t$‹uˆ‰L$‹M„‰T$‰|$ ‰D$‹½<ÿÿÿ‰t$‹u‰|$ ‰L$‰4$èüÿÿÿ¸“‰ƒ‰$èüÿÿÿ‹}”¶ÿÿÿ‹³D‹}„‹ƒ@‹Mˆ‰7»‰‰½ÿÿÿ‹ƒ0‰|$‹•@ÿÿÿ¯À‰|$ ‰L$ ‹µ<ÿÿÿ‰t$‹µÿÿÿ‰4$èüÿÿÿ‰|$‹ƒ0‹½@ÿÿÿ‰Â¯Ð ׉L$ ‹…ÿÿÿ‰D$‹½8ÿÿÿ‰4$‰|$èüÿÿÿº‹}ˆ‹E„‰T$‹µ8ÿÿÿ‹UŒ‰t$‹<ÿÿÿ‰|$‹µtÿÿÿ‰D$ ¿‰L$‰4$‰T$èüÿÿÿ‹Eˆ1ɉ‹8‹0NˆÜUÄEÀ‰• ÿÿÿM¼‰…ÿÿÿU¸‰ÿÿÿ‰•ÿÿÿë]ÙHÿÿÿ‹M„‹‹8ÿÿÿú‹DÑü‰E¼‹…ÿÿÿ‰D$‹DÑø‹ÿÿÿ‰E¸‰ $èüÿÿÿÙ]Ô‹U€Ù…HÿÿÿÙEÔÙÉØ Úéßàžrÿƒ8GNxY‹M„‹‹<ÿÿÿú‹DÑü‰EÄ‹… ÿÿÿ‰D$‹DÑø‹ÿÿÿ‰EÀ‰ $èüÿÿÿÙHÿÿÿÙ…HÿÿÿÙƒLÙÉÝéßàž‚QÿÿÿÝØéPÿÿÿƒ»4—‹U„‹ ‰ÊJxS‹…8ÿÿÿÙî‰ÖƒÀ‰…äþÿÿë$z6Ýéßàžuz‹}ˆ‰ñvÿ‹E„ÿ‰ƒ…äþÿÿJx‹½äþÿÿÙGüÙÙÉÝêßàžtÈÝØëÞÝØ‹“8;“@}‹µpÿÿÿ‹»,9>|…É…Bƒ»48‹½dÿÿÿ¹º‹ƒH¾‰O‹MŒ‰Gƒ8‰Ç‰t$ ³:‰T$‰…0ÿÿÿ‰D$‰ $èüÿÿÿ…ÀU¶‰•ÿÿÿ„”‰t$‹UŒ¹‰L$ ¸‰D$‰$èüÿÿÿ…À„B‹MŒ¿¾‰|$»<‰t$ ³>‰|$‰ $èüÿÿÿ…À„Ô‰t$‹uŒ¸‰D$ º‰T$‰4$èüÿÿÿ…À„‚‹UŒ¿¸‰|$ »@³B‰D$‰|$‰$èüÿÿÿ…À„$‰t$‹uŒº‰T$ ¹‰L$‰4$èüÿÿÿ…À„Òº‰T$‹8ÿÿÿ‰L$‹µ<ÿÿÿ‰t$ ‹…ÿÿÿ‰D$‹½ÿÿÿ‰|$‹•ÿÿÿ‰$èüÿÿÿ‹‹@I‰ôþÿÿˆÍ}¬‹µ8ÿÿÿE°‰½$ÿÿÿ‹½<ÿÿÿƒÆ‰… ÿÿÿëGÝØÙFüÙÁÙáÙÙîÝâßàÝÚžvpÙÃØòÜÌÙÀØÊÙÍÞÃÙÃÞÉÙÌÞãÞÃÜùÞúÙÉÙ^üƒÇÙƒÆÿôþÿÿxc‹O‹… ÿÿÿ‰M°‰D$‹‹$ÿÿÿ‰U¬‰ $èüÿÿÿÙ]ÔÙEÔÙƒLÙÉÝáßàžrÝÙé|ÿÿÿÙÁØôÙÁØÉÙËØÉÙËØÄÙÌÞÉÙÊÞÄÞáÙÉØòÙÉÞò늸¿¾‰|$ ‰D$‹0ÿÿÿ‰L$‹•ÿÿÿ‰$èüÿÿÿ‰t$ƒ@‹½<ÿÿÿU¶‰|$‹½8ÿÿÿ‰D$‰|$ ‹ÿÿÿ‰$‰L$èüÿÿÿ‹³@N‰µðþÿÿˆ‹u¤U¨‰µ,ÿÿÿ‰þ‹½<ÿÿÿ‰•(ÿÿÿƒÆë0ÝØÙFüƒÇÙîÙÙÂØÌÙÊØÉÙÉÞÌÞéÙîÞÊÙ^üÞÁÙƒÆÿðþÿÿx<‹O‹…(ÿÿÿ‰M¨‰D$‹‹,ÿÿÿ‰U¤‰ $èüÿÿÿÙ]ÔÙEÔÙƒLÙÉÝáßàžr˜ÝÙë–¿“8‰|$‹8ÿÿÿ‹}Œ‰L$‹…<ÿÿÿ‰T$‰D$ ‹µÿÿÿ‰<$‰t$èüÿÿÿƒ»4‹…pÿÿÿ‹“,9}A‹ƒ8;ƒ@} ‹LÿÿÿÇ‹u„‹>…ÿu;ƒ@} ‹LÿÿÿÇ‹}„‰éðóÿÿ‹ƒ8ëÑ‹}ˆ‹M„‹“8‹7¿‰uØ‹³D‰UàM؉E܃‰t$‹³‰|$‰L$~‰|$ ‰D$‰4$èüÿÿÿ‰|$ ‹^º‰L$‰T$‹…<ÿÿÿ‰D$‹•ÿÿÿ‰4$‰T$èüÿÿÿ‰|$ ¹5ƒ|‰L$‰D$‹•8ÿÿÿ‰T$‹½ÿÿÿ‰4$‰|$èüÿÿÿé¬úÿÿ³±¿‰t$‹³‰|$~‰|$ ‹<ÿÿÿ‰L$‹…ÿÿÿ‰4$‰D$èüÿÿÿ‰|$ º‹Ë‰T$‰L$‹…8ÿÿÿ‰D$‹•ÿÿÿ‰4$‰T$èüÿÿÿévþÿÿ³ì‹ƒ0¿'‰t$‹³¯À‰|$~‰|$ ‹•@ÿÿÿ ‰L$‹…ÿÿÿ‰4$‰D$èüÿÿÿ‰|$ ‹»0¹*‰L$“‰T$‰ù‹…@ÿÿÿ¯ÏùȉT$‹ÿÿÿ‰4$‰L$èüÿÿÿé8úÿÿ‰|$¸º‰D$ ‰T$‹µÿÿÿ‰4$èüÿÿÿé•úÿÿ‰t$¹¸‰L$ ‰D$‰$èüÿÿÿéIúÿÿ‰|$¾¸‰t$ ‰D$‹½ÿÿÿ‰<$èüÿÿÿéûÿÿ‰t$¸º‰D$ ‰T$‹ÿÿÿ‰ $èüÿÿÿé³úÿÿ‰|$¾¹‰t$ ‰L$‹½ÿÿÿ‰<$èüÿÿÿéUúÿÿ‰t$¹¸‰L$ ‰D$‹•ÿÿÿ‰$èüÿÿÿéúÿÿ³@¸7‰t$‹³‰D$ƒV‰•ÿÿÿ‰T$ ‰L$‰…Dÿÿÿ‰D$‰4$èüÿÿÿ“x¹+‰L$‹M„‰T$‹…ÿÿÿ‰L$‰D$ ‹•Dÿÿÿ‰4$‰T$èüÿÿÿéíïÿÿ‹…tÿÿÿƒ8„0‹‹4…ÉŽù¾4»¤ƒ8‰t$‹³‰|$‰D$~‰|$ ‹•ÿÿÿ‰4$‰T$èüÿÿÿƒ»4Ž°‹Uˆ‹M„‹º‰EØ‹‹Ø‰EÜE؉T$“‰L$‰|$ ‰T$‰D$‰4$èüÿÿÿ‰|$ ‹U„¹‰L$ƒî‰D$‹<ÿÿÿ‹‰4$Á‹Mˆ‰T$‰L$èüÿÿÿ‰|$ ‹M„¸.‰D$“ ‰T$‹‹½8ÿÿÿ‰4$‹MˆljT$‰L$èüÿÿÿ‹µtÿÿÿ‹…À…Díÿÿ‹}˜¹‰‹(Çéíÿÿ‹Eˆ‰ÏÁï‹09Ñø‰³<9Ð~‰Ðƒøtf‹Uˆ‰‹“0‹Mˆ‹ƒøtm‹}„)Â9ð‰Ž‰þÿÿ¾‹MŒ‰t$‹…8ÿÿÿ‹µtÿÿÿ‰D$‹•<ÿÿÿ‰|$ ‹}ˆ‰T$‰L$‰|$‰4$èüÿÿÿéGþÿÿ‹“0ƒú~#‰×‹MˆÁï:Ñø‰듃ú~ŽÇ¸ë‹EˆÇéiÿÿÿ_naup2: **** Start of major iteration number ****Epsilon-Machine_naup2: B-norm of residual for compressed factorization_naup2: Compressed upper Hessenberg matrix H_naup2: The number of shifts to apply _naup2: values of the shifts_naup2: Ritz estimates of the shifts_naup2: Corresponding B-norm of the residualLMSMLRSRLISI_naup2: NEV, NP, NCONV are_naup2: The eigenvalues of H_naup2: Ritz estimates of the current NCV Ritz values_naup2: Sorted eigenvalues_naup2: Sorted ritz estimates._naup2: Eigenvalues computed by _neigh:_naup2: Ritz estimates computed by _neigh:_naup2: The length of the current Arnoldi factorization_naup2: Extend the Arnoldi factorization by_naup2: no. of "converged" Ritz values at this iter._naup2: NEV and NP are_naup2: "wanted" Ritz values _naup2: Ritz estimates of the "wanted" values ‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@p ˆ!h %°+°P4°0 ð' >´:FðSzŠ#'“Ð$ ä¤ñÿ  #(08 @$I(S,[0e4o8x<‚@ŠD‘HšL£  ¸½ÂÈ  ÎÕpÝ ô !) `òÿ07?GK |òÿSZahow‡•cnaup2.ft0.0t1.1t2.2t3.3t4.4t5.5cnorm.6getv0.7initv.8update.9ushift.10iter.11kplusp.12msglvl.13nconv.14nevbef.15nev0.16np0.17rnorm.18eps23.19__g77_forceload_0.20.LC2.LC4.LC10.LC25cswap_cnaup2___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_cnaitr_ccopy_cnapps_arscnd_debug_ivout_cgetv0_slamch_powtiming_svout_cmout_cvout_cdotc_slapy2_scnrm2_cneigh_cngets_s_cmpcsortc_s_copy& 'é ÷ ý  ž(Â Û ã  ) ”*Ÿ ¥ ­+Û á ç ö    , 6-< E t © À ã.õ  " : B+H,[ e k s y ‹ ‘ ›/¸0¾ Ë Õ Ý ã ö  $ K ^ l+r x1~ ’  §,¾ Î2Ù 3 # 5,; V-e †4¤ Å4? I a(” ¦ · ¿+Å Ë1Ô ë 576E V i7q1w ¦)Ì ó)  ^ | 8£ ­ ,³ Ê 2Õ Þ é ÷ ' )1 a )¦ 9±  69 p 6‚ œ    , I ] i  :± :Ð Ú æ : :. 4 D :m :´ ;º T6` Ã<Í ú; 6‹ £ Ô;Ú í ÷ ý  8 F X g !q,Œ-– ¿4Î ò4ý  ,34B f4q w †,³4½ Ì ö4<B<k<”<½<æ<ñ ,  --3 c-}  –  ,Á-Ç æ ö "-$ F4\ ~4œ ¼ Õ +96 $cnaupd.o/ 1189291779 1000 1000 100644 6868 ` ELF@4( U‰åWVS켋M ‹UèüÿÿÿËu‹E‰Mè‹M$‰Uì‹}‰uÜ‹u<‰Eä‹E0‰MÔ‹Mì‰}à‹U‰uÄ‹}4‰EЋ‰UØ‹UH…À‰}̉UÈ„J‹‹X‰M°‹»‹³ ‹‹,¸º‰D$h‹EȉT$d‹UD‰D$`‹E8‰T$\‹ỦD$X‰T$T‹UÄDÊø‰D$P‹4Dòø‰D$Htúø»0‰t$D‹³‰L$L‹M°‰|$<‹}(DÊø‰D$@‹M,Dòø‰D$8³Dƒ$‰L$4“(‹<‰|$0‹} ‰uÀ‰t$,‹u؉D$(ƒT‰T$$“L‰L$ ‰|$‰t$‰E¼‹Mà‰D$‹}ä‰T$‹uè‹Eì‰L$ ‰|$‰t$‰$èüÿÿÿ‹U싃øtƒøc„ˆļ[^_]˳T‹}Љwļ[^_]öèüÿÿÿ“‰$èüÿÿÿ‹‹¸º‹qD‹MЉƒH‹Eä‹9‰³@‹q‰»$‹y¹ÿÿÿÿ‰³<‹0‰»D‰“(…öŽÉ‹Eܹþÿÿÿ‹…ÒŽ·‹MÔ‹9ÐŽÊ9ðÂ…ÿ¹üÿÿÿŽ•‹}ฺ‰D$ ³‰T$‰t$‰<$èüÿÿÿ…À… ‹M趌*‹“<¹öÿÿÿrÿƒþ‡J„ù‹‹H…ÉŽ¸‹uØÙîÙÙÉÚéßàžƒƒƒ»$v ¸‰ƒ$‹MÔ‹}Ü‹ ‰M¨‰Ê‰È¯Ñ‹7)ð‰³L…ÿtHÄŒ[^_]˺+‰T$‹U܉L$‹MÀ‰|$‰t$ A‰D$‰T$‰T$‰ $èüÿÿÿéãþÿÿ‹M´‹uÔ‹}ЉL$‹E܉t$ ‰|$‹‹U¼‹}ÜtÊð‰t$‰<$èüÿÿÿƒ}Ä“‹u̺¹‰T$@‹},‹E܉t$8‰|$4‹}܉L$<‹‹U¸‰|$,‹EЯɉ|$(‹}܉D$$4ÊMì‰t$0Eà‹U¼‰|$‰L$‹?‰T$ “D‰|$‹u¸‰|$ ‰D$‰t$‰T$‰ $èüÿÿÿ‹uÌ‹>…ÿ…êþÿÿ‹}Ü‹‰ÇOxe‹EÈuä‰u°‹u¼Áà‰E¬t&‹E´‰t$‹U܉D$‰$èüÿÿÿÙ]è‹M´‹UÜÙEèØ»‰L$ ‰t$‹E°Ù]ä‰D$‰$èüÿÿÿ‹M¬ÎOy¶‹}Ü‹ƒ}ÄÁ‹U´‹MÔ‹u܉T$‹U܉L$ ‰t$‹}¼‰$DÇø‰D$èüÿÿÿ‹M´‹uÔ‹}‰L$ ‹E܉t$‰|$‰$èüÿÿÿƒ}Ä׃‰$èüÿÿÿÙƒ‹“Ø«ØBXÙZXÄŒ[^_]ÓH¸*‹}Ô‰D$‹E܉T$‹MÀ‰|$‰D$q‰t$ ‹UÀ‰$èüÿÿÿé2þÿÿ‹U´‹uЉT$‹M¸‰t$‹Uܳt‰L$ ‹}¼‰$DÇø‰D$èüÿÿÿ‰t$¹0‹U܉L$‹‹y‰|$ ‹E¸‰T$‰ $‰D$èüÿÿÿ‹uÜ‹éÔþÿÿ³¤‹MØ¿‰t$‹³‹E܉|$~‰|$ ‰L$‰D$‰4$èüÿÿÿ‰|$ ‹Eܺ/‰T$‹}Ô‹À‰L$‰D$‰|$‰4$èüÿÿÿéÁþÿÿAll€?_neigh: Entering upper Hessenberg matrix H RightBack_neigh: last row of the Schur matrix for H_neigh: Last row of the eigenvector matrix for H_neigh: The eigenvalues of H_neigh: Ritz estimates for the eigenvalues of H€?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@m 0 8 %°+°0°ï8 E¨l¬|¬#Ï…\  l Ãñÿ  #(- 2m:Qgo `òÿv~†Ž•œ¤¬´ |òÿ¼cneigh.ft0.0t1.1t2.2t3.3t4.4t5.5.LC4.LC8cneigh___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_clacpy_claset_clahqr_cmout_ccopy_ctrevc_scnrm2_csscal_timing_cvout_ N Y_Ž ¦¸ Å ä÷ =W ‰¾& 0 O’¤ ¾ 0 8> DJ a ‘ ° ÇÝ÷  7 P d cneupd.o/ 1189291779 1000 1000 100644 10424 ` ELFì4( U‰åWVSìÌ‹}‹u èüÿÿÿËE‹M‰½tÿÿÿ‹U‰µpÿÿÿ‹}‰…lÿÿÿ‹u ‰hÿÿÿ‹E$‰•dÿÿÿ‹M(‰½`ÿÿÿ‹U,‰µ\ÿÿÿ‹}0‰…øþÿÿ‹u4‰Xÿÿÿ‹E8‰•Tÿÿÿ‹M@‰½Pÿÿÿ‹UD‰µLÿÿÿ‰…Hÿÿÿ‰Dÿÿÿ‰•@ÿÿÿ‹}H‹uX‹Ed‹UL‰½<ÿÿÿ‹‹‰µÿÿÿ‹}P‰…8ÿÿÿ‹q\‹B‹8ÿÿÿ‰µÿÿÿ‹rº‰E ƒÇ‰$‰T$èüÿÿÿÙ]Ô¹`ºUUå?ÙEÔ‰L$‰T$ Ý$èüÿÿÿÙ´þÿÿ‹E …ÀŽ®‹•Tÿÿÿ‹ …ÉŽÅ‹•Lÿÿÿ‹…ÀŽš‹•Dÿÿÿ‹9‰•„þÿÿ~9ÊŽŒÇE˜ýÿÿÿFÿƒø†ƒþ„ ÇE˜öÿÿÿN„/‹E˜…Àt‹½8ÿÿÿ‰ÄÌ[^_]ô&‹G‹•Dÿÿÿ‹O‰…ÿÿÿ‹w‹‰4ÿÿÿ‰µ0ÿÿÿ‰ÂÁ‰(ÿÿÿ¯ÐÁ‰,ÿÿÿÁ‰E”‹µ,ÿÿÿ‰ ÿÿÿщ$ÿÿÿ‹(ÿÿÿ‰Eœ‰w(‹µ$ÿÿÿ‰O ‹ ÿÿÿ‰w0‹³‰O,‹O4ʉ•ÿÿÿЋ0ÿÿÿ‰…ÿÿÿ‹•ÿÿÿ‹DÊ‹|Ê ‰EÀ‹ƒ‰}ĉtʉDÊ ƒ½ÿÿÿ,‹…tÿÿÿ‹…Ò„Œ‹Dÿÿÿ1ÿ‰½ ÿÿÿ‹1ÇE€‰ñI‰µ€þÿÿx]‹…lÿÿÿ¾‹•4ÿÿÿ‹½ÿÿÿ‰…„þÿÿD×ü¶¼'VFÛ$ƒÄÇÙXü‹½„þÿÿƒÀǃÇI‰½„þÿÿyÔ‰u€‹•Lÿÿÿ¿‹ )€þÿÿÇE¸‹µ€þÿÿ‰u¼‰|$‹ÿÿÿ‹…4ÿÿÿTÁøE¼‰•Üþÿÿ‰T$‹µÿÿÿ‹•Lÿÿÿ|ñø‹Pÿÿÿ‰½Øþÿÿu¸‰|$‰D$ ‰T$‰L$‰4$èüÿÿÿƒ½ÿÿÿ—ÇE¤‹•Dÿÿÿ‹ÇE€‰ÇOˆ*u´M°‰µÄþÿÿ‰Èþÿÿëz¶Ù]„‹•Dÿÿÿ‹…4ÿÿÿ‹ ‹U€È‹ÿÿÿ)ÐÙDÁø‹E Ù½~ÿÿÿ·µ~ÿÿÿfÎ f‰µ|ÿÿÿ9E¤Ù­|ÿÿÿÛxÿÿÿÙ­~ÿÿÿ‹µxÿÿÿŒ1JO‰M€ˆ¤‹•Dÿÿÿ‹‹•ÿÿÿ‹M€Ð)È‹ÿÿÿ‹•Äþÿÿ‹tÁü‰u´‰T$‹tÁø‹Èþÿÿ‰u°‰ $èüÿÿÿÙ]ÔÙEÔÙ…´þÿÿÙÉÝáßàÙ]„ž‚7ÿÿÿÝØé3ÿÿÿº¸‹‰T$ U؉D$‰L$‰$èüÿÿÿN…Ñüÿÿ‹µXÿÿÿ€>G…ÂüÿÿÇE˜õÿÿÿé¶üÿÿÇE˜òÿÿÿé‡üÿÿÇE˜þÿÿÿé{üÿÿÇE˜¹º‰L$ ‹Pÿÿÿƒ‰T$‰D$‰ $èüÿÿÿ…À…N ‹Xÿÿÿ¶A„ª‰U€éXôÿÿ¸¹“ô‰D$ ‹…Pÿÿÿ‰L$‰T$‰$èüÿÿÿ…À„€òÿÿº¸‹ö‰T$ ‹•Pÿÿÿ‰D$‰L$‰$èüÿÿÿ…À„Nòÿÿ¹ºƒø‰L$ ‹Pÿÿÿ‰T$‰D$‰ $èüÿÿÿ…À„òÿÿ¸¹“ú‰D$ ‹…Pÿÿÿ‰L$‰T$‰$èüÿÿÿ…À„êñÿÿº¸‹ü‰T$ ‹•Pÿÿÿ‰D$‰L$‰$èüÿÿÿ…À„¸ñÿÿÇE˜ûÿÿÿéîíÿÿfÙÂØôÜËÙÁØÉÙÌÞÅÙËØÂÙÊÞËéµõÿÿ‹pÿÿÿ¶V h <šž ­ Ø ç   5 V e ‰ ž µ   9 H y ® À × ç ò  " q € ª º Ô F Ž E«!   ?"’#­ $$l$z °¿ $X$„ ž¶ Ðè  4L fr | %² ¼ãö 1&BM Š• ÃÛ &ã ù'Or ®( )2 q*Ç+"} ‰ “ », %/^q ¼&cngets.o/ 1189291779 1000 1000 100644 2100 ` ELFL4( U‰åWVSƒì<‹M‹UèüÿÿÿË}³‹E‰Mä‰Uà‰}؉4$‰EÜèüÿÿÿ‹‹º‹EØ‹}܉MÔ‹qX‹Mà‰T$‹Uä‰D$‰|$ ‹9Mð‹‹U ‰L$lj}ð»‰|$‰$èüÿÿÿ‹Eƒ8„ƒ‰$èüÿÿÿÙƒ…ö‹‹Ø«ØA\ÙY\ŽÛ‰|$‹MÔ³‰t$‹E争T$q‰t$ ‰ $‰D$èüÿÿÿ‰|$‹Eຠ‰T$‹}Ô‹‰L$‰t$ ‰<$‰D$èüÿÿÿ‰t$ ‹Eܺ(‰T$‹}à‹‰L$‹Uä‰D$‹‹ ‹UÔ}ì‰|$ȉ$‰Eìèüÿÿÿ‰t$ ‹}ع8‰L$‹uàƒD‰D$‹Uä‰|$‹}è‹ ‰|$‹uÔȉEè‰4$èüÿÿÿƒÄ<[^_]É|$‹Eܺ‰T$‹MØ‹Uà‰D$ƒ|‰L$ ‰T$‰$èüÿÿÿéºþÿÿ_ngets: KEV is_ngets: NP is_ngets: Eigenvalues of current H matrix _ngets: Ritz estimates of the current KEV+NP Ritz valuesSM‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@Ú „° %+0~8œE l¤|¤#Ç…T   ôñÿ  #( - `òÿ4 |òÿ<ÚD[qyˆcngets.ft0.0t1.1t2.2t3.3t4.4t5.5.LC0debug_timing_cngets___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_csortc_ivout_cvout_  6<x „– ž¤ ¬² Ë î 4 Zs ™Á Ñcgetv0.o/ 1189291779 1000 1000 100644 4632 ` ELFt 4( U‰åWVS윋E ‹UèüÿÿÿË}‹u‰E¼‹E(‰UÀ‹M ‰}¸‹U$‰u´‹},‰E¨‹ƒ‰M°‹u0‰U¬‹M4‰}¤‹U8…À‰u ‰M˜‰Uœt4º¸¿‰“ ¾1ɉƒ$‰»(‰³,‰‹‹MÀ‹1…ö„¬‹‹…É„á‹}¼¶G…ïûÿÿ‹³‹U¸‹} ÿ³Ç‹‹U¨@‰G‹M˜‰t$‹E¸‰t$‰L$ ‰T$‰$èüÿÿÿ‹}ÀÇÿÿÿÿé?ÿÿÿ¿+‹E¨³¨‰|$‹»‹M¸‰t$W‰T$ ‰D$‰L$‰<$èüÿÿÿéÕþÿÿ³ ‰4$èüÿÿÿÙƒ‹³‹Ø« ØFhÙ^h‰ $èüÿÿÿ‹U¼¸‰ƒ¶ K V `!j „" ±"Ä Ö à!æ "  '- 39 R \b!x  ‡   ¥·Å ò# !6$A IO U[ a o} ™ ·#Å Ø%ò  & % +4 K sŽ ¢ ° Ã%Ë Û#H#\ ‚#csortc.o/ 1189291779 1000 1000 100644 2908 ` ELF¼4( U‰åWVS쬋U‹}èüÿÿÿËE‹M ‰UÈ‹u‰}À‹:º‰EĉøÁè‰MÌÇÑÿ‰}¸¹ƒ‰L$ ‰T$‰D$‰4$èüÿÿÿ…À…6‹u¸…ö„ ‹}¸‹UÈ‹E¸÷×:‰E¼‰}°ˆðUì}è‰U˜uä‰}”Mà‰u‰MŒ‹}¼t&‹E¸)Ç…ÿˆ·‹UÄ‹M˜‹tú‰L$‹ú‰uì‹u”‰Eè‰4$èüÿÿÿÙ]´‹M¸‹E4‹MÄ‹Tñ‰D$‰Uä‹ñ‹MŒ‰Uà‰ $èüÿÿÿÙ]ðÙEðÙE´ÚéßàžvZ‹EÄ‹ø‹LøÙðÙøÙDðÙ\ø‰ð‹ỦLð‹…À„jÿÿÿ‹MÀ‰È‹ùÙð‹LùÙøÙDðÙ\ø‰ð‰Lð‹E¸)Ç…ÿ‰IÿÿÿÿE¼ÿM°‰(ÿÿÿ‹}¸Áï}¸Ñ}¸‹u¸…ö…àþÿÿĬ[^_]É4$¹º‰L$ ƒ‰T$‰D$èüÿÿÿ…À…A‹u¸…öt‹}¸‹U¸‹EÈ÷׉•xÿÿÿ8‰}¬ˆ EÜ}؉EˆuÔ‰}„MЉu€‰|ÿÿÿ‹½xÿÿÿ´&¼'‹U¸)×…ÿˆÂ‹UÄ‹Mˆ‹tú‰L$‹ú‰uÜ‹u„‰E؉4$èüÿÿÿÙtÿÿÿ‹M¸‹E€4‹MÄ‹Tñ‰D$‰UÔ‹ñ‹|ÿÿÿ‰UЉ $èüÿÿÿÙ]ðÙEðÙ…tÿÿÿÙÉÚéßàžvZ‹EÄ‹ø‹LøÙðÙøÙDðÙ\ø‰ð‹ỦLð‹…À„_ÿÿÿ‹MÀ‰È‹ùÙð‹LùÙøÙDðÙ\ø‰ð‹U¸‰Lð)×…ÿ‰>ÿÿÿÿ…xÿÿÿÿM¬‰ÿÿÿ‹}¸Áï}¸Ñ}¸é¿þÿÿ‰4$¹º‰L$ ƒ‰T$‰D$èüÿÿÿ…À…¿‹u¸…ö„Qþÿÿ‹}¸‹U¸‹EÈ÷׉•pÿÿÿ8‰}¨ˆ‡‹µpÿÿÿ‹M¸)Î…öxi‹U¸<‹UÄÙòÙúÙÉÝáßàž†HÙɉыTòÙñ‹Dù‰Dñ‹EÌÙù‰Tù‹…Ét¸‹MÀ‰È‹ñÙø‹LñÙðÙDøÙ\ð‰Lø‹M¸‰ø)Î…öy—ÿ…pÿÿÿÿM¨‰yÿÿÿ‹u¸Áîu¸Ñ}¸éAÿÿÿ‰4$º¸‰T$ »‰D$‰|$èüÿÿÿ…À…ЋM¸…É„fýÿÿ‹u¸‹E¸‹}È÷Ö‰…lÿÿÿ7‰u¤x{‹µlÿÿÿ‹U¸)Ö…öxa‹M¸‹UÄ<ÙòÙúÝáßàžvy‰Ñ‹TòÙñ‹Dù‰Dñ‹ẺTùÙù‹…ÒtÀ‹MÀ‰È‹ñÙø‹LñÙðÙDøÙ\ð‰ø‹U¸‰Lø)Ö…öyŸÿ…lÿÿÿÿM¤y…‹u¸Áîu¸Ñ}¸éQÿÿÿÝØÝØÿ…pÿÿÿÿM¨éüþÿÿÝØÝØÿ…lÿÿÿÿM¤ë̉4$º¸‰T$ »‰D$‰|$èüÿÿÿ…À…‹M¸…É„jüÿÿ‹u¸‹E¸‹}È÷Ö‰…hÿÿÿ7‰u ˆŠ‹½hÿÿÿ‹U¸)×…ÿxi‹M¸‹UÄ4ÙDúÙDòÙÉÝáßàÝÙžv[‹ú‰Ñ‹ò‰ù‹Tñ‰Tù‰ñ‹EÌÙ\ñ‹…Òt¸‹MÀ‰È‹ùÙð‹LùÙøÙDðÙ\ø‰ð‹U¸‰Lð)×…ÿy—ÿ…hÿÿÿÿM étÿÿÿÝØëî‹u¸Áîu¸Ñ}¸é>ÿÿÿ‰4$º¸‰T$ » ‰D$‰|$èüÿÿÿ…À…‡ûÿÿ‹M¸…É„|ûÿÿ‹u¸‹E¸‹}È÷Ö‰…dÿÿÿ7‰uœˆ†‹½dÿÿÿ‹U¸)×…ÿxe‹M¸‹UÄ4ÙDúÙDòÝéßàžv[‹ú‰Ñ‹ò‰ù‹Tñ‰Tù‰ñ‹EÌÙ\ñ‹…Òt¼‹MÀ‰È‹ùÙð‹LùÙøÙDðÙ\ø‰ð‹U¸‰Lð)×…ÿy›ÿ…dÿÿÿÿMœéxÿÿÿÝØëî‹u¸Áîu¸Ñ}¸éBÿÿÿLMSMLRSRLISI‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@Î Ì %+0 8_ o #Cxœ à  | Mñÿ Î)?Ecsortc.fcsortc___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_s_cmpslapy2_  L ` Û  µ  K | " /     ÷  cstatn.o/ 1189291779 1000 1000 100644 1172 ` ELF<4( èüÿÿÿÁU‹º‰åÇÇ@Ç@Ç@ Ç@‰PL‰PP‰PT‰PX‰P\‰P`‰Pd‰Pt‰Pp‰Px‰Ph‰Pl]Ë $ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.gnu.linkonce.t.__i686.get_pc_thunk.cx.note.GNU-stack.comment@a | %¤+¤0¤W¨g¨#Ëpô   eñÿ  #( |òÿ0a8Ocstatn.ft0.0t1.1t2.2t3.3t4.4t5.5timing_cstatn___i686.get_pc_thunk.cx_GLOBAL_OFFSET_TABLE_ znaitr.o/ 1189291779 1000 1000 100644 10572 ` ELF`4( U‰åWVS쬋E‹MèüÿÿÿËu‹}‰…$ÿÿÿ‹E(‰ ÿÿÿ‹M,‰µ,ÿÿÿ‹U ‰½ÿÿÿ‹u ‰…ìþÿÿ‹}0‰ÿÿÿ‹E<‰•(ÿÿÿ‹U$‰µÿÿÿ‹u4‰½àþÿÿ‹½ÿÿÿ‰…èþÿÿ‹M@‰•ÿÿÿ‹U8‰µ ÿÿÿ‹7‰•ÿÿÿ‰ÿÿÿ‰µÿÿÿ‹• ÿÿÿ‹‰…üþÿÿ‹‹…É…r‹µ,ÿÿÿ‹…Ò„Ù‹»$…ÿ…å‹‹(…É„X³“‰µþÿÿ‰• þÿÿ‹(ÿÿÿ¶‰ÁùƒøŒÒ‰E)Á‰Â‰ÎNˆÜ݃Xÿÿÿ½Pÿÿÿ݃Ùɉ¤þÿÿ…Hÿÿÿ‰½¨þÿÿ@ÿÿÿ‰…¬þÿÿ½8ÿÿÿ‰°þÿÿE¤‰½´þÿÿ‹¦‰…Øþÿÿ½0ÿÿÿ‰ÔþÿÿÝÈþÿÿÝÀþÿÿëJt&ÝØÚéßàžr-Ý…Èþÿÿ‹U‹üþÿÿBÿ¯ÁЋ•àþÿÿÁàÝÝ…ÀþÿÿÝ\‹E@N‰E‰Âˆ‹üþÿÿBÿ¯Á‹àþÿÿÐÁàÈ‹•¤þÿÿÝ@øÝXÿÿÿ‰T$Ý@ð‹…¨þÿÿÝPÿÿÿ‰$èüÿÿÿ‹M‹…üþÿÿÝðþÿÿ‹U¯Á‹¬þÿÿЋ•àþÿÿÁàÝDÝHÿÿÿ‰L$Ý‹•°þÿÿÝ@ÿÿÿ‰$èüÿÿÿÜ…ðþÿÿÙîÙÉÝáßàÝÙÝðþÿÿžtc‹U‹üþÿÿBÿ¯Á‹àþÿÿÐÁà‹•´þÿÿÝDÝ8ÿÿÿ‰T$ÝÝ0ÿÿÿ‰<$èüÿÿÿ݃XÝ…ðþÿÿÜ‹`Ýáßàž‚·þÿÿÝÙé²þÿÿz›‹$ÿÿÿ¸‰D$‹•èþÿÿ‹‹ ÿÿÿÁàЉL$ ‹•ÿÿÿ‹ ÿÿÿ‰D$‹…àþÿÿ‰D$‹‹Ћ•Øþÿÿ‰E¤‰T$‹…Ôþÿÿ‰$èüÿÿÿÝðþÿÿé/ÿÿÿf݃€ÙÉ¿1³¨Ý]à“EØÝ]؉t$‹³‰|$‰T$~‰|$ ‰D$‰4$èüÿÿÿ‰|$ ƒÙ¹‰L$‹‹D‰D$‹•üþÿÿƒDI‹½àþÿÿ¯ÊÁáù‰L$‰…Œþÿÿ‰D$‰4$èüÿÿÿé2ôÿÿ¶ÝØU”¹‰L$(‰•¼þÿÿ‹ƒD‰T$$‹•$ÿÿÿH‰T$ ‹µÿÿÿ‹½ìþÿÿ¯Æ³Áàø‹½ÿÿÿ‰D$‹œþÿÿ‰T$‰L$‰µäþÿÿ‰t$u‰|$ »ñ‰t$‰t$‰<$èüÿÿÿº‹$ÿÿÿ‰T$(‹…¼þÿÿ‰L$ ‰D$$‹ƒ0‹•èþÿÿÁàLð‰L$‹…œþÿÿ‹$ÿÿÿ‰D$‹…ÿÿÿ‰L$‹•äþÿÿ‰D$ ‰t$‰T$‰t$‰<$èüÿÿÿéÛúÿÿ»‹“0‹µÿÿÿ‰|$‹èþÿÿÁâ‰|$ ½xÿÿÿD ð‰D$‹•$ÿÿÿE¸‰$‰T$‰t$èüÿÿÿÝEÀpÿÿÿÝxÿÿÿ‰|$ÝE¸Ýpÿÿÿ‰ $èüÿÿÿÙú‹•ÿÿÿÝéuòÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹½(ÿÿÿØ« Ø@lÙXl¶é!òÿÿ³øº(»D‰t$‹³‰T$F‰…”þÿÿ‰|$»‰D$ ‰|$‰4$èüÿÿÿ¹)“ ‰L$‹ÿÿÿ‰T$‹…”þÿÿ‰L$‰|$‰D$ ‰4$èüÿÿÿéäôÿÿÿF¹‰‹(‹µÿÿÿ‹½,ÿÿÿ‹‹4‹ƒ0lj‰FĬ[^_]Ë“ÿB‹•ÿÿÿ‹½Üþÿÿ‹³4‰|$‹èþÿÿÁæ‰|$‰T$Dð‹$ÿÿÿ‰D$ ‰ $èüÿÿÿ늋þÿÿ‹ƒ0‹µÿÿÿ‰L$‹•èþÿÿÁà‰L$ ‰t$|ð‹•$ÿÿÿ‰|$EÈ}ˆ‰T$‰$èüÿÿÿÝEÐM€Ý]ˆ‰|$ÝEÈÝ]€‰ $èüÿÿÿÙúÝ›€éïÿÿ“ ‰$èüÿÿÿÙƒ‹ƒ‹½(ÿÿÿØ« Ø@lÙXl¶éÏîÿÿ‹½ÿÿÿƒ‹µ$ÿÿÿ‰D$‰|$‰4$èüÿÿÿé÷ýÿÿ‹½þÿÿ‹ÿÿÿ‹µ$ÿÿÿ‰|$‰L$‰4$èüÿÿÿésÿÿÿ‹µþÿÿ‹»0‰t$‹•èþÿÿÁ狵ÿÿÿLð‹½$ÿÿÿ‰L$ ‹…þÿÿ‰t$‰<$‰D$èüÿÿÿ‹•(ÿÿÿ¶éÙïÿÿÝØé‚óÿÿ‹³ÿF‹µÿÿÿ‰|$‹ƒ4‹èþÿÿ‰|$‹½$ÿÿÿÁà‰t$Tð‰T$ ‰<$èüÿÿÿ‹•ÿÿÿ‹‹4‹ƒ0‹µ,ÿÿÿ‰ ‰BÇé&øÿÿ³ ‰4$èüÿÿÿÙƒ‹ƒ‹(ÿÿÿØ« Ø@lÙXl¶À·FxS`˜‡œ—œ#¿ à`/ @Úñÿ  #(08@ I$R([,c0j4q8x<€@ˆDH—PŸX©`°h¸pÁxË€Ô   éîóùþ    t 5KRZ |òÿbi `òÿpw†Ž–ž¦®µ¼ÄËÓznaitr.ft0.0t1.1t2.2t3.3t4.4t5.5first.6orth1.7orth2.8rstart.9step3.10step4.11ierr.12ipj.13irj.14ivj.15iter.16itry.17j.18msglvl.19ovfl.20smlnum.21ulp.22unfl.23betaj.24rnorm1.25wnorm.26__g77_forceload_0.27.LC5.LC2.LC16.LC8.LC9.LC18.LC10zscal_znaitr___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_zgemv_arscnd_timing_zaxpy_debug_ivout_zgetv0_zcopy_dlamch_dlabad_zdscal_dlapy2_zlanhs_dvout_zvout_zlascl_zdotc_dznrm2_zmout_1 2³ Ñ ß í 'ó  3 "I z › "§ "¹ Å3ä  "+ "C3I T v ( ‡4’  4Ë ç )í 5    3 9 "C 'h r "— "±3Ê ó " "'31 T w6‚ ˆ 4¿ É Ó "Þ è7î ' 8  )( E S a o *u   ž ¤ ­ ²4¸ ¾5Ê Ü ç ÷  ( % 3 > "H7N 'i8o5y „ Š  *™ Ÿ ¼ E9Z h r ~ „ •4› ¡5­ Ä Ì4Ò Ú5à ì 'ø  /:5 C4h Ÿ:ª ¶4¼7Ë Ù á í ÿ    " ( 3 "> G P ;V (\ "d  "‡ Œ <— "£ ;© µ ¿ Å â è 'ô 3 :9 T +k — =£ Ê =Ð 5Û á ë 4÷  I :U [ a Š · :Ò Ú 4à ò + "= "x "% >p >È >Î Ú O?b o "x ,ˆ7£@­ "¼ Ì ñA : -n "~B¡ êBõ 'û 9C]>r z4€ †5’ ¦ "± »7Ò 'â8í "@( : @ \5q œ:ª åC>  4! '53 M 'cDŠD› Ò:í5 ':3 9 U ]4c i5u Œ '’ ÐCô>ü   ")7pE{5†  ¥ "± " " , ,D@U 'kD/znapps.o/ 1189291779 1000 1000 100644 8672 ` ELFh4( U‰åWVSì|‹M‹u èüÿÿÿËU‹}‰<ÿÿÿ‹M‰µ8ÿÿÿ‹u ‰•4ÿÿÿ‹E‰½hþÿÿ‹U$‰,ÿÿÿ‹},‰µèþÿÿ‹u8‰…0ÿÿÿ‹E(‰•(ÿÿÿ‹•,ÿÿÿ‰½„þÿÿ‹M4‰µlþÿÿ‹}0‰…$ÿÿÿ‹‰ ÿÿÿ‹(ÿÿÿ‰…ÿÿÿ‹1‰µÿÿÿ‹ƒ‹…À‰•ÿÿÿ…€³‰4$èüÿÿÿ‹³‹•4ÿÿÿ‹8ÿÿÿ‹FT‰…ÿÿÿ‹‹‰|$‹»‰½Lþÿÿк‰…lÿÿÿ‹…„þÿÿ‰T$•lÿÿÿ‰D$ƒ ‰|$‰Hþÿÿ‰L$ ‰•dþÿÿ‰T$‰T$‰$èüÿÿÿ‹½4ÿÿÿ‹…À„ ¹»H‰hÿÿÿ‰½Dþÿÿ‰… ÿÿÿˆs݃‰µÿÿÿ~“#‰½Äýÿÿ}Ü…hÿÿÿÝøýÿÿ‹>‰•ÿÿÿ‹•Äýÿÿ‰½ þÿÿ‹½ÿÿÿ‰…`þÿÿƒT‰ÿÿÿ³~‰•þÿÿMà‰…þÿÿ‹…`þÿÿ‰½ þÿÿ‹½þÿÿ‰üþÿÿ“‰µþÿÿdÿÿÿ‰…þÿÿ³œ‰þÿÿƒÇ‰µþÿÿ‹ä‰•þÿÿµ`ÿÿÿ‰àþÿÿ•\ÿÿÿ‰½ÜþÿÿM˜‰µ\þÿÿ}¨‰…ØþÿÿµPÿÿÿ‰•XþÿÿE¸‰ìýÿÿUÈ݃‰½èýÿÿ‰µäýÿÿ‰…àýÿÿÝðýÿÿÝ…øýÿÿ‰•ÜýÿÿÝÐýÿÿÝ…ðýÿÿÝÈýÿÿ‹µhÿÿÿ‹•0ÿÿÿÁæÖÝFðƒ½ÿÿÿÝ]àÝFøÝ]èÜ‹lÿÿÿ¸‰…`ÿÿÿ‹µ`ÿÿÿ‰Ï)÷‰µdÿÿÿ‰þNˆä ‹•þÿÿ‹þÿÿ‹… þÿÿ‰•øþÿÿ‹•þÿÿ‹½þÿÿ‰ôþÿÿ‹þÿÿ‰…ðþÿÿ‰•ìþÿÿ‰äþÿÿë!ÝÚÙÉÙÉÚéßàžƒ¿JN‰dÿÿÿˆy ‹•dÿÿÿ‹ÿÿÿBÿ¯Á‹èþÿÿÐÁàÈ‹èþÿÿÝ@ðÝ@øÙÉ‹…ÿÿÿÙáÙÉÙá¯ÂÞÁÐÁàÝÝDÙÉÙáÙÉÙáÞÁÙîÙÊÞÁÝáßàÝÙž„º݃(‹ÿÿÿBÿÞɯÁ‹èþÿÿ݃ ÐÁàÝÙÊÝáßàÙÊžÙá‚?ÿÿÿÝÙÙÉÚéßàž‚Aÿÿÿ‹½ÿÿÿ…ÿŽÐ‹½þÿÿ¾*‹•øþÿÿ‰t$‹ðþÿÿ¾+‰|$‹…ôþÿÿ‹½Dþÿÿ‰T$‰ $‰|$‰D$ èüÿÿÿ‰|$‹•ìþÿÿ‹þÿÿ‰t$‹½ðþÿÿ¾‰T$‹…ôþÿÿ‰L$‰<$‰D$ èüÿÿÿ‰t$‹…ôþÿÿ‹µdÿÿÿ‰<$‹ÿÿÿ‹•äþÿÿ‰D$ Fÿ¯Á‰T$‹•èþÿÿð‹µDþÿÿÁàЉD$‰t$èüÿÿÿ‹•dÿÿÿÝ…øýÿÿ‰•\ÿÿÿ‹…ÿÿÿzÿ‹èþÿÿ¯ø×ÁçÝÝ…ðýÿÿÝ\ƒ½ÿÿÿŽÈ‹µÜþÿÿ¹‹½\þÿÿ‰L$‹…àþÿÿ‰t$ ‹µDþÿÿ‰|$‹½ÿÿÿ‰D$‰t$‰<$èüÿÿÿ‰t$º‹Øþÿÿ‰T$‹…Üþÿÿ‹•Xþÿÿ‰L$‰D$ ‰T$‰<$èüÿÿÿ‹`ÿÿÿ‹µ\ÿÿÿ9ñ…VN‰`ÿÿÿ‹lÿÿÿ9ÎŒýÿÿÿ…hÿÿÿÿ ÿÿÿ‰Îüÿÿ‹•8ÿÿÿ¿‹ ‰ÎN‰µ”þÿÿˆ„ÙƒUˆE܉•þÿÿ•pÿÿÿHÿÿÿ‰•<þÿÿ‹•ÿÿÿµ@ÿÿÿ‰…Œþÿÿ‹…„þÿÿÁâ‰TþÿÿxÿÿÿЉ…8þÿÿ‹…ÿÿÿ‰@þÿÿ‹èþÿÿÁà‰µPþÿÿÁµtÿÿÿ‰µˆþÿÿ1ö‰0þÿÿ1ɉµ(þÿÿ‰$þÿÿ‰…,þÿÿ‰•4þÿÿéPÙÃØóÜÌÙÀØÊÙÍÞÄÙÂÞÉÙÌÞâÞÃØñÙÊÞñÙÉÝU€‹µ$þÿÿ‹ÿÿÿÙàÙÉ‹…(ÿÿÿ‹•èþÿÿÝ•xÿÿÿ¯Î‰D$ Ý]ˆÝ]49Áæ‹•lÿÿÿ‹þÿÿ‰D$‹…Œþÿÿ)ú‰L$B‰U܉$èüÿÿÿ‹•0þÿÿ‹…@þÿÿ‹Dþÿÿ‰T$‹•lÿÿÿ‰D$G9ЉL$ ~‰Ð‰…tÿÿÿ‹ˆþÿÿ‰ $èüÿÿÿ‹•Dþÿÿ‹…8þÿÿ‹@þÿÿ‰T$ ‹•4ÿÿÿ‰D$‰L$‹‹•lÿÿÿø@9Ð~‰Ð‰…pÿÿÿ‹•<þÿÿ‰$èüÿÿÿ‹…èþÿÿÙîÝTÿ…$þÿÿG‹…ÿÿÿ…(þÿÿ‹,þÿÿ‹µ4þÿÿ0þÿÿµ8þÿÿÿ”þÿÿˆÙ ‹(þÿÿ‹µèþÿÿùÁáÝ1ÙÉÝáßàÝÙžw ÝD1ÝéßàžztÝØ‹ÿÿÿ‹µ$þÿÿ‹…èþÿÿ‹•Tþÿÿ¯ñ‹PþÿÿþÁæÝD‰T$ÝHÿÿÿ݉ $Ý@ÿÿÿèüÿÿÿÙÀ‹•èþÿÿÙáÙîÝÙÉÝâßàÝÚÝDž‡þÿÿÙÂØôÙÁØÉÙÌØÉÙÌØÃÙËÞÉÙËÞÄÞâØòÙÉÞòéþÿÿ‹µ8ÿÿÿ‹‹…ÿÿÿqÿ‹½èþÿÿ¯ð1ÁâÝ:Úéßàž‡b ‰Î¿N‰½dÿÿÿˆƒ½pÿÿÿ‰…¸ýÿÿë‹•8ÿÿÿ‹ ‰|$º‹…Dþÿÿ‰T$,‹•lþÿÿ‰D$(‹…Hþÿÿ‰T$$‹•Dþÿÿ‰D$ ‹…ÿÿÿ‰T$‹•dÿÿÿ)ѯÁ‹„þÿÿÁàÈ‹hþÿÿ‰D$‹…,ÿÿÿ‰L$‹lÿÿÿ‰D$‹…Lþÿÿ)ÑA‰D$ ‹…<ÿÿÿ‰pÿÿÿ‹¸ýÿÿ‰D$‰ $èüÿÿÿ‹•dÿÿÿ‹…lÿÿÿ‹Dþÿÿ)Ћ•ÿÿÿ‰L$‰L$¯Â‹•hþÿÿ‹<ÿÿÿÁàЉD$ ‹…lþÿÿ‰ $‰D$èüÿÿÿÿ…dÿÿÿN‰ÿÿÿ‹µ8ÿÿÿ‹‹…hþÿÿ¿‹•ÿÿÿ‰|$‹µ,ÿÿÿ‹½hþÿÿ‰D$‹…lÿÿÿ‰t$‰t$)È‹µ8ÿÿÿ¯Â‹<ÿÿÿ“‰t$‰L$Áàø‰$‰D$ èüÿÿÿÙƒ‹½8ÿÿÿ‹…ÿÿÿ‹‹½èþÿÿrÿ¯ð 2ÁáÝ9Úéßàž‡• ‹½Dþÿÿ‹ÿÿÿ‹…„þÿÿ‰|$ zÿ¯ù‹•lÿÿÿ‹µ$ÿÿÿ‹<ÿÿÿÁçÇÁâ‰t$tð‰t$‰ $èüÿÿÿÙƒ‹…8ÿÿÿ‹•ÿÿÿ‹µèþÿÿ‹yÿ¯ú9ÁâÝ2Úéßàž‡¿ ƒ½ÿÿÿŽ3³‹8ÿÿÿ¿(‰t$‹³‹•ÿÿÿ‰|$~‰|$ ‹‹„þÿÿ‰4$H¯Â‰…ÿÿÿÁà‰Â‹…lÿÿÿÊÁàLð‹•Dþÿÿ‰L$‰T$èüÿÿÿ‰|$ ‹•8ÿÿÿ¹%‰L$ƒ0‹ÿÿÿ‰D$‹‰4$Pÿ¯Ñ‹DþÿÿЋ•èþÿÿ‰L$ÁàЉD$èüÿÿÿ‰|$ º-‹8ÿÿÿ‰T$‹•DþÿÿƒX‰D$‰L$‰T$‰4$èüÿÿÿƒ½ÿÿÿ~A‰|$º6ƒˆ‰T$‹(ÿÿÿ‹•èþÿÿ‰D$‹…8ÿÿÿ‰L$‰T$ ‰D$‰D$‰4$èüÿÿÿ»‰<$èüÿÿÿÙƒ‹³Ø«ØF`Ù^`Ä|[^_]Ê@÷ÿÿÝ؉L$‹… ÿÿÿº‰T$‹•(ÿÿÿ‹hÿÿÿ‰D$‹…lÿÿÿ‰T$ ‹• þÿÿ)ȉ<$@‰T$‰EÜèüÿÿÿ‹•dÿÿÿéîöÿÿ‹lÿÿÿ‰\ÿÿÿƒ½ÿÿÿ8øÿÿ‹`ÿÿÿ‹µ\ÿÿÿ9ñ„ªøÿÿ‹•8ÿÿÿ9 ŒœøÿÿÝEà‹•ÿÿÿAÿÝEèÙÉ‹½èþÿÿ¯ÂÈÁà8ÜjðÙÉÜjøÝD8‰÷)ÏÝÙËOÝ]ÈÙÉÝ]ÐÝ]ÀÝ]¸‰dÿÿÿ‰½Ôþÿÿ´&ˆ>øÿÿ‹àýÿÿ‹•ìýÿÿ‹…èýÿÿ‰L$‹½äýÿÿ‹µÜýÿÿ‰T$‰D$ ‰|$‰4$èüÿÿÿ‹dÿÿÿ;`ÿÿÿ~8ÝE˜‹•ÿÿÿyþ‹µèþÿÿ¯úÏÁç7ÝXðÝE ÝXøÝ…ÐýÿÿÝÝ…ÈýÿÿÝ\7‹…lÿÿÿ‰Ï‰Æ)Îy éf‹dÿÿÿÝ…Pÿÿÿ‹•ÿÿÿGÿÝE¨GÝE°¯ÂÙÁÈ‹èþÿÿÁàNJð‰´ýÿÿÝBðÝÈþÿÿÝA‹èþÿÿݨýÿÿÝ…ÈþÿÿØÌÝÀþÿÿÙîܨýÿÿÜ­ÀþÿÿÝÀþÿÿÝ…¨ýÿÿØÌݸþÿÿÙîÜÈþÿÿÜ…¸þÿÿݸþÿÿÝDÝÙÁÙÁÙÉØÍÙÉØÎÙÌØËÙÌÞáÙÁØÍÙÉÜ…ÀþÿÿÙÍÙàÙÉÞÄÝ…ÈþÿÿÙÌÜ…¸þÿÿÙÍÝ•ÀþÿÿÙÌØÎÙÌÝxÿÿÿÙÆØÊÙÍݸþÿÿÙÎØÊÝ…¸þÿÿÙÎܨýÿÿÙÎÝ]€ÙîÞËÙÌÞâÙîÞÉÝ…¨ýÿÿØÎÙÌÞÁÙÍÜÈþÿÿÙÊÞãÞâÜÂÝÈþÿÿÙÊÞáÙÉÝÝ\Ý…ÀþÿÿÝZð‹´ýÿÿÝ…¸þÿÿÝY‰ þÿÿ‹dÿÿÿ‹•\ÿÿÿA9Ð~‰Ð‰Ç¾O‰µÀýÿÿy éO‹dÿÿÿÝ…Pÿÿÿ‹µÿÿÿQÿÝE°‹…ÀýÿÿÙÁÝE¨Ùʯ֋µèþÿÿÙàÙÂÂÁâ‹…ÿÿÿòÝBðrð¯ÁÜËÙË‹ÀýÿÿÈ‹èþÿÿÁàÝ°þÿÿÙîÈÜNHðÜ­°þÿÿÝ°þÿÿÝFØÍݨþÿÿÙîØËÜ…¨þÿÿݨþÿÿÙÁÝ@ðÝAÙËØÉÙÊØËÙÌØÉÙÊÞäÙÅÙÌÜ…°þÿÿÙÌØËÙÌÝ•°þÿÿÙÌÞÂÙÆÙÊÜ…¨þÿÿÙÊØÉÙÏØËÙÊݨþÿÿÝ…¨þÿÿÙÌÝxÿÿÿÙÄØÎÙÌÝ]€ÙîÞËÙÌÜM°ÙÍÜNÙÎÞâÙîÞÌÙÌÞÅÝFÜM°ÙÌÞÃÙÊÞäÞâÞáÝXðÝYÝ…°þÿÿÝZðÝ…¨þÿÿÝ^ÿ…ÀýÿÿO‰¸þÿÿ‹dÿÿÿ‹½hÿÿÿ‰È‹•lÿÿÿø9Ð~‰Ð‰ÇºO‰•¼ýÿÿyéU´&‹dÿÿÿÝ…Pÿÿÿ‹µÿÿÿQÿÝE°‹…¼ýÿÿÙÁÝE¨Ùʯ֋µ„þÿÿÙàÙÂÂÁâ‹…ÿÿÿòÝBðrð¯ÁÜËÙË‹¼ýÿÿÈ‹„þÿÿÁàÝ þÿÿÙîÈÜNHðÜ­ þÿÿÝ þÿÿÝFØÍݘþÿÿÙîØËÜ…˜þÿÿݘþÿÿÙÁÝ@ðÝAÙËØÉÙÊØËÙÌØÉÙÊÞäÙÅÙÌÜ… þÿÿÙÌØËÙÌÝ• þÿÿÙÌÞÂÙÆÙÊÜ…˜þÿÿÙÊØÉÙÏØËÙÊݘþÿÿÝ…˜þÿÿÙÌÝxÿÿÿÙÄØÎÙÌÝ]€ÙîÞËÙÌÜM°ÙÍÜNÙÎÞâÙîÞÌÙÌÞÅÝFÜM°ÙÌÞÃÙÊÞäÞâÞáÝXðÝYÝ… þÿÿÝZðÝ…˜þÿÿÝ^ÿ…¼ýÿÿO‰¸þÿÿ‹dÿÿÿ‹µ\ÿÿÿ~ÿ9Ï~2‹½ÿÿÿAÿ‹•èþÿÿ¯ÇÈÁàÝÝ]ÈÝDÐÝ]ÐÝ@Ý]¸Ý@Ý]ÀÿÔþÿÿA‰…dÿÿÿé¿úÿÿ‹µÄýÿÿº‹½`þÿÿ‰T$‹ÿÿÿ‰t$ ‹µDþÿÿ‰|$‹½ÿÿÿ‰L$‰t$‰<$èüÿÿÿ‰t$¸‹•ÿÿÿ‰D$‹Äýÿÿ‹…üþÿÿ‰T$‰L$ ‰D$‰<$èüÿÿÿé­ïÿÿ¹ ³¾‰L$‰4$³ÊèüÿÿÿÙƒ“ƒ0݃‰T$ÙÁØó‰$ÜÊÞÉÙÊÝ“0ÞÁÙÉ܃ÞñÝ›èüÿÿÿ‰4$¹ ‰L$èüÿÿÿ‹•<ÿÿÿ1ÀÝ“(‰ƒÛÞñÜ‹0Ý› éãìÿÿ‹½8ÿÿÿ‹‰ÎºN‰•dÿÿÿˆÍôÿÿ݃»~Ýxþÿÿ݃ÝpþÿÿëTÝØ‹…èþÿÿÝÙÉÚéßàžr0Ý…xþÿÿ‹ÿÿÿBÿ¯ÁЋ•èþÿÿÁàÝÝ…pþÿÿÝ\‹•dÿÿÿBN‰…dÿÿÿˆQôÿÿ‹•dÿÿÿ‹ÿÿÿBÿ¯Á‹èþÿÿÐÁàÈ‹èþÿÿÝ@ðÝ@øÙÉ‹…ÿÿÿÙáÙÉÙá¯ÂÞÁÐÁàÝÝDÙÉÙáÙÉÙáÞÁÞÁÝáßàžt6݃(‹ÿÿÿBÿ݃ ÙÉÞÊÙɯÁ ÁáÝáßàž‚ ÿÿÿÝÙéÿÿÿzÈÝØÝ؉<$‹• ÿÿÿ¸‰D$‹(ÿÿÿ‹…èþÿÿ‰T$‹•8ÿÿÿ‰L$ ‰D$‰T$èüÿÿÿ‹•dÿÿÿÙîÙÉé|ÿÿÿº‹…<ÿÿÿ‹µlþÿÿ‰T$,‹•Dþÿÿ‰T$(‹8‹…Hþÿÿ‰T$Áç‹•„þÿÿ‰D$ ÷‹µÿÿÿ‰|$$‹…Lþÿÿ‹½hþÿÿ¯ñ‹,ÿÿÿ‰|$‰D$ ÁæÖ‰t$‹•<ÿÿÿ‹µdþÿÿ‰L$‹‰ $‰t$‰T$èüÿÿÿ‹½8ÿÿÿ‹éóÿÿ‹…ÿÿÿ‹½$ÿÿÿ‹µDþÿÿ¯È‰|$‰t$‰t$ ‹µhþÿÿ‰ÿÿÿÁá‰Ï‹èþÿÿ÷‰|$ ‹•<ÿÿÿ‰D$‰$èüÿÿÿééôÿÿ‹ÿÿÿ‹½Dþÿÿ‹…lþÿÿ¯Ê‹•hþÿÿ‰|$‰|$ÁáщL$ ‹•<ÿÿÿ‹2‰$ÁæƉt$èüÿÿÿ‹8ÿÿÿ‹éôÿÿÙƒéEýÿÿð?All_napps: Value of the shift _napps: shift number._napps: matrix splitting at row/column no.1_napps: off diagonal element._napps: matrix splitting with shift number._napps: End of current block _napps: Start of current block NA_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}_napps: betak = e_{kev+1}^T*H*e_{kev}_napps: Order of the final Hessenberg matrix _napps: updated Hessenberg matrix H for next iterationsafe minimumprecision‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@˜ 0° %Ø+à80àÓ8´E¼lÀ|À#ã…p°    ñÿ  #(07 @(F0NS X˜`w• `òÿœ¤«²¹ÁÈÏ×Þ |òÿæîöþznapps.ft0.0t1.1t2.2t3.3t4.4t5.5first.6ovfl.7smlnum.8ulp.9unfl.10.LC7.LC2znapps___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_zlaset_ivout_zvout_zscal_dlapy2_zgemv_zcopy_zlacpy_zmout_timing_zlanhs_zlartg_dlamch_dlabad_zaxpy_ ¤ º ÂÈë ñ  B] | ‹ ¦ Ê Ö   ' 3  Ý ÷ qª÷y¬  +lµk ú ª !ö "U n #t ì ò 3 H • ® ã   . ` $f n t z %€ Þ &¸ 'ü/? L Q(W ] c i € Š ’ —)¨(¶ ¼ Æ Ì ó ù  Ä Ó 3& Ò!2*|" znaup2.o/ 1189291780 1000 1000 100644 10668 ` ELFü4( U‰åWVS쌋u‹U èüÿÿÿËM‹E‰µdÿÿÿ‹}‰•`ÿÿÿ‹u‰\ÿÿÿ‹U ‰…Xÿÿÿ‹M$‰½Tÿÿÿ‹E(‰µPÿÿÿ‹}0‰•Lÿÿÿ‹u4‰Hÿÿÿ‹U8‰…Dÿÿÿ‹M<‰½@ÿÿÿ‹E@‰µ<ÿÿÿ‹}D‰•8ÿÿÿ‰4ÿÿÿ‰…0ÿÿÿ‰½,ÿÿÿ‹UL‹ET‹uH‹}X‰•ÿÿÿ‹U`‰…$ÿÿÿ‹…dÿÿÿ‰µÿÿÿ‹MP‰½ÿÿÿ‹u\‰•üþÿÿ‹8‰(ÿÿÿ‹Md…ÿ‰µ ÿÿÿ‹uh‰ÿÿÿ‰µÿÿÿ„‡‹ƒ…À…•‹³$»H…ö„‹…ÿÿÿº¹‰“$‹• ÿÿÿ‰L$<‹,ÿÿÿ‰D$8‹µüþÿÿ‰T$0‹…0ÿÿÿ‰L$,‹•8ÿÿÿ‰|$‹Hÿÿÿ‰t$4‹µ4ÿÿÿ‰D$(‹…Dÿÿÿ‰t$$‹µPÿÿÿ‰T$ ‹•Tÿÿÿ‰L$‹\ÿÿÿ‰D$‹…`ÿÿÿ‰t$‹µdÿÿÿ‰T$ ‰L$‰D$‰4$èüÿÿÿ‹•dÿÿÿƒ:c„˜ÄŒ[^_]˃(…À„V‹•@ÿÿÿ‹1öH‰³(t0“‹…Pÿÿÿ‰T$‹ÿÿÿ‰T$‰L$ ‹½ÿÿÿ‰$‰|$èüÿÿÿƒ»4#‹µüþÿÿ‹…$ÿÿÿ‹(ÿÿÿ‰t$0‹½Hÿÿÿ‹•ÿÿÿ‰D$(‹µ,ÿÿÿ‹…4ÿÿÿ‰T$,‹•0ÿÿÿ‰L$$‹8ÿÿÿ‰t$‹µPÿÿÿ‰T$‹•Tÿÿÿ‰D$‹…\ÿÿÿ‰L$‰|$ ‹½ÿÿÿ‰t$‰T$‰|$ »‰$èüÿÿÿ‰<$¹‰‹èüÿÿÿ‹µ`ÿÿÿ¶1ÒÝ›P1É1À‰“$…ÿ‰‹(‰ƒt2Ç¿‰» é¸ûÿÿ‹“…Ò„Å‹•`ÿÿÿ¶é–ýÿÿ1ö‰³ éûÿÿ‹ÿÿÿ‹…ÀŽéÇñØÿÿ‹•Pÿÿÿ‹³,‹½<ÿÿÿ‰‰7‹…dÿÿÿ³Çc‰4$èüÿÿÿÙƒ‹“Ø«ÙZPÄŒ[^_]ó@¸7“‰t$‹³‰D$N‰¬þÿÿ‰L$ ‰T$‰|$‰4$èüÿÿÿ¸,‹x‰D$‹…,ÿÿÿ‰L$‹•¬þÿÿ‰4$‹0ÿÿÿ‰D$‰T$‹•Tÿÿÿ‰L$ ‰T$‰T$èüÿÿÿ‹“4éÂüÿÿ³¤‹…Pÿÿÿ¿&‰t$‹³‹‰|$~‰L$‰|$ ‰D$‰4$èüÿÿÿ‰|$ ºƒÊ‰T$‹•Pÿÿÿ‰D$‹ÿÿÿ‰T$‰4$‰L$èüÿÿÿ‹…@ÿÿÿƒ8…_ûÿÿ‰|$ º$ƒè‰T$‹•Pÿÿÿ‰D$‹ÿÿÿ‰T$‰4$‰L$èüÿÿÿé'ûÿÿ‹ÿÿÿ¸‹• ÿÿÿ‰D$<‹…,ÿÿÿ‰L$8‹µüþÿÿ‰T$0‹0ÿÿÿ‰D$,‹…Hÿÿÿ‰|$‹•8ÿÿÿ‰t$4‹µ4ÿÿÿ‰L$(‹Dÿÿÿ‰t$$‹µTÿÿÿ‰D$‹…\ÿÿÿ‰L$‹`ÿÿÿ‰t$‹µdÿÿÿ‰T$ “‰T$ ‰D$‰L$‰4$èüÿÿÿƒ>c…úÿÿ‹•ÿÿÿ‹…ÀŽ‰þÿÿÇñØÿÿ‹Pÿÿÿ‹³,‹½<ÿÿÿ‰é«ýÿÿ‹dÿÿÿ1ÿ‰»Çéùÿÿ» ‰<$èüÿÿÿÙƒ‹ƒ‹`ÿÿÿØ« Ø@lÙXl¶ÿÿÿ‹ƒD‹µPÿÿÿ‹“@‹Tÿÿÿ‰³‰‰µøþÿÿ‹“0‰t$‹½ÿÿÿ¯Ò‰t$Áâú‰T$ ‹ÿÿÿ‰L$‹…ðþÿÿ‰$èüÿÿÿ‰t$‹»0‹•ÿÿÿ‰t$‰ù¯ÏùÁáщL$ ‹…ÿÿÿ‰D$‹½ðþÿÿ‰<$èüÿÿÿº‹½Xÿÿÿ‹…Pÿÿÿ‰T$‹ÿÿÿ‹•@ÿÿÿ‰L$‹µÿÿÿ‰|$¿‰t$‹µTÿÿÿ‰D$ ‰$‰t$èüÿÿÿ‹61ɉ‹8NˆãE¸U°‰…ÌþÿÿM¨‰•ÐþÿÿE ‰Ôþÿÿ‰…Øþÿÿë^Ýÿÿÿ‹Pÿÿÿ‹•ÿÿÿ‹‹ÔþÿÿøÁàÐÝ@øÝ]¨‰L$‹•ØþÿÿÝ@ðÝ] ‰$èüÿÿÿÝ…ÿÿÿ‹LÿÿÿÜ Úéßàžrÿƒ8GNx_‹•Pÿÿÿ‹ÿÿÿ‹‹•ÌþÿÿøÁàÈÝ@øÝ]¸‰T$‹ÐþÿÿÝ@ðÝ]°‰ $èüÿÿÿÝÿÿÿÝ…ÿÿÿ݃PÙÉÝéßàž‚JÿÿÿÝØéIÿÿÿƒ»4Ì‹•Pÿÿÿ‹ ‰ÊJxMÙƒ‰Ö‹½ÿÿÿƒÇë&z2Ýéßàžuz‹…Pÿÿÿ‰ñvÿ‰‹…TÿÿÿÿƒÇJxÝGøÝÙÉÝêßàžtÌÝØëèÝØ‹“8;“@}‹µ<ÿÿÿ‹»,9>|…É…±ƒ»4”݃Hº¾‹½0ÿÿÿƒ8‹XÿÿÿÝ_ ÙƒÝ_(‰Ç‰t$ ³:‰T$‰…ôþÿÿ‰D$‰ $èüÿÿÿ…ÀUž‰•Üþÿÿ„ü‰t$‹•Xÿÿÿ¹‰L$ ¸‰D$‰$èüÿÿÿ…À„§‹Xÿÿÿ¿¾‰|$»<‰t$ ³>‰|$‰ $èüÿÿÿ…À„6‰t$‹µXÿÿÿ¸‰D$ º‰T$‰4$èüÿÿÿ…À„á‹•Xÿÿÿ¿¸‰|$ »@³B‰D$‰|$‰$èüÿÿÿ…À„€‰t$‹µXÿÿÿº‰T$ ¹‰L$‰4$èüÿÿÿ…À„+º‰T$‹ÿÿÿ‰L$‹µÿÿÿ‰t$ ‹…ðþÿÿ‰D$‹½øþÿÿ‰|$‹•Üþÿÿ‰$èüÿÿÿ‹‹@I‰¸þÿÿˆå‹…ÿÿÿu}ˆ‰µàþÿÿ‹µÿÿÿ‰½äþÿÿ‰ÇƒÇ‰…ÈþÿÿëVÝØÝGøÙÁÙáÝÙîÝâßàÝÚžv}ÙÃØòÜÌÙÀØÊÙÍÞÃÙÃÞÉÙÌÞãÞÃÜùÞúÙÉ‹ÈþÿÿƒÆƒÇÝÝYƒÁÿ¸þÿÿ‰ÈþÿÿxdÝF‹•àþÿÿÝ]‰T$‹äþÿÿÝÝ]ˆ‰ $èüÿÿÿ݃PÙÉÝáßàž‚tÿÿÿÝÙéoÿÿÿÙÁØôÙÁØÉÙËØÉÙËØÄÙÌÞÉÙÊÞÄÞáÙÉØòÙÉÞòézÿÿÿ¹¿¾‰|$ ‰L$‹…ôþÿÿ‰D$‹•Üþÿÿ‰$èüÿÿÿ‰t$ƒ@‹½ÿÿÿuž‰|$‹ÿÿÿ‰D$‰L$ ‹•øþÿÿ‰4$‰T$èüÿÿÿ‹»@O‰½´þÿÿˆµxÿÿÿ‹½ÿÿÿU€‰µìþÿÿ‹µÿÿÿ‰•èþÿÿƒÆë0ÝØÝFøƒÇÙîÝÙÂØÌÙÊØÉÙÉÞÌÞéÙîÞÊÝ^øÞÁ݃Æÿ´þÿÿx9ÝG‹•èþÿÿÝ]€‰T$‹ìþÿÿÝÝxÿÿÿ‰ $èüÿÿÿ݃PÙÉÝáßàžr›ÝÙ뙿ƒ8‰|$‹•ÿÿÿ‹½Xÿÿÿ‰T$‹ÿÿÿ‰D$‰L$ ‹µøþÿÿ‰<$‰t$èüÿÿÿƒ»44‹<ÿÿÿ‹“,9}G‹ƒ8;ƒ@} ‹½ÿÿÿÇ‹µPÿÿÿ‹…Éu;ƒ@} ‹½ÿÿÿÇ‹Pÿÿÿ‰é‚óÿÿ‹ƒ8ëË‹…Tÿÿÿ‹Pÿÿÿ‹“8‹8¸‰}Ø‹1»D‰UàMØ“‰u܉|$‹»‰D$w‰µÀþÿÿ‰t$ ³^‰L$‰T$‰<$èüÿÿÿ‰t$¸¾5‰D$‹Àþÿÿ‰L$ ‹•ÿÿÿ‰T$‹…ðþÿÿ‰<$‰D$èüÿÿÿ‰t$‹|‰L$‹•Àþÿÿ‰T$ ‹…ÿÿÿ‰D$‹µðþÿÿ‰<$‰t$èüÿÿÿé_úÿÿ³±¸‰t$‹³‰D$~‰½°þÿÿ‰|$ ‹•ÿÿÿ»Ë‰T$‹ðþÿÿ‰4$‰L$èüÿÿÿ‰|$¸‰D$‹•°þÿÿ‰T$ ‹ÿÿÿ‰L$‹…ðþÿÿ‰4$‰D$èüÿÿÿéLþÿÿ³ì¿'‰t$‹³‰|$V‰•¼þÿÿ‹‹0‰T$ ‹…ÿÿÿ¯ÉÁáÁ‰L$‹½ðþÿÿ‰4$‰|$èüÿÿÿ‹»0ƒº*‰D$‰T$‹¼þÿÿ‰ø¯Ç‰L$ ‹•ÿÿÿøÁàЉD$‹ðþÿÿ‰4$‰L$èüÿÿÿéÌùÿÿ‰|$¸º‰D$ ‰T$‹µÜþÿÿ‰4$èüÿÿÿé0úÿÿ‰t$¹¸‰L$ ‰D$‰$èüÿÿÿéáùÿÿ‰|$¾¸‰t$ ‰D$‹½Üþÿÿ‰<$èüÿÿÿé¬úÿÿ‰t$¸º‰D$ ‰T$‹Üþÿÿ‰ $èüÿÿÿéWúÿÿ‰|$¾¹‰t$ ‰L$‹½Üþÿÿ‰<$èüÿÿÿéöùÿÿ‰t$¹¸‰L$ ‰D$‹•Üþÿÿ‰$èüÿÿÿé¡ùÿÿ³@¸7‰t$‹³‰D$ƒV‰•Äþÿÿ‰T$ ‰L$‰… ÿÿÿ‰D$‰4$èüÿÿÿ‹xº+‰T$‹•Pÿÿÿ‰L$‹…Äþÿÿ‰T$‰D$ ‹ ÿÿÿ‰4$‰L$èüÿÿÿé5ïÿÿ‹…@ÿÿÿƒ8„I‹‹4…ÉŽ¾4»¤ƒ8‰t$‹³‰|$‰D$~‰|$ ‹•øþÿÿ‰4$‰T$èüÿÿÿƒ»4ŽÆ‹•Tÿÿÿ‹Pÿÿÿ‹º‰EØ‹M؉E܃؉T$“‰|$ ‰L$‰T$‰D$‰4$èüÿÿÿ‰|$ ‹•Pÿÿÿ¸‰D$‹î‰L$‹ ‹…ÿÿÿ‰4$‹•TÿÿÿÁáÁ‰L$‰T$èüÿÿÿ‰|$ ‹½Pÿÿÿ¸.‰D$‹ ‰L$‹‹•ÿÿÿ‰4$‹TÿÿÿÁàЉD$‰L$èüÿÿÿ‹µ@ÿÿÿ‹…À…aìÿÿ‹½dÿÿÿ¹‰‹(Çé$ìÿÿ‹…Tÿÿÿ‰ÏÁï‹09Ñø‰³<9Ð~‰Ðƒøtu‹•Tÿÿÿ‰‹“0‹Tÿÿÿ‹ƒøt{‹Pÿÿÿ)Â9ð‰Ždþÿÿ¾‹½Tÿÿÿ‰t$‹…ÿÿÿ‹µ@ÿÿÿ‰D$‹•ÿÿÿ‰L$ ‹Xÿÿÿ‰T$‰|$‰L$‰4$èüÿÿÿéþÿÿ‹“0ƒú~+‰×‹TÿÿÿÁï:Ñø‰ë‡fƒú~€Ç¸épÿÿÿ‹…TÿÿÿÇéRÿÿÿ_naup2: **** Start of major iteration number ****Epsilon-Machine_naup2: B-norm of residual for compressed factorization_naup2: Compressed upper Hessenberg matrix H_naup2: The number of shifts to apply _naup2: values of the shifts_naup2: Ritz estimates of the shifts_naup2: Corresponding B-norm of the residualLMSMLRSRLISI_naup2: NEV, NP, NCONV are_naup2: The eigenvalues of H_naup2: Ritz estimates of the current NCV Ritz values_naup2: Sorted eigenvalues_naup2: Sorted ritz estimates._naup2: Eigenvalues computed by _neigh:_naup2: Ritz estimates computed by _neigh:_naup2: The length of the current Arnoldi factorization_naup2: Extend the Arnoldi factorization by_naup2: no. of "converged" Ritz values at this iter._naup2: NEV and NP are_naup2: "wanted" Ritz values _naup2: Ritz estimates of the "wanted" values UUUUUUå?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.rodata.rodata.cst8.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@– ,#x%Ø+ØX4Ø0 ¤)>Ü:FS `4‡8—8#[ |' |!®ñÿ  #(08 @$I(S,[0e4o8x<‚@ŠD‘HšP£   ¸ ½ ÂÇ Ì Ò  Øß–ç þ#+3 `òÿ:AIQU |òÿ]dkry‰‘™Ÿ§znaup2.ft0.0t1.1t2.2t3.3t4.4t5.5cnorm.6getv0.7initv.8update.9ushift.10iter.11kplusp.12msglvl.13nconv.14nevbef.15nev0.16np0.17rnorm.18eps23.19__g77_forceload_0.20.LC2.LC3.LC1.LC4.LC10.LC25zswap_znaup2___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_znaitr_zcopy_znapps_arscnd_debug_ivout_zgetv0_dlamch_powtiming_dvout_zmout_zvout_zdotc_dlapy2_dznrm2_zneigh_zngets_s_cmpzsortc_s_copy) *   3 Å+å þ  0,6 Á É-× Ü.    ( 2 = G/Q h0n z ¯ ç  '1< B !a m ˆ .–/² ¼ Â Ì Ò Ø å ï2õ "3    % + > I g Ž ¤ ².¸ ¾4Ä Ø ã í/5 U6[ f {/ œ0« Ï7í 7Ÿ #³+Þ ù   . 4* A x8œ9¤ µ Ë:Ó4Ù ,6 ` ,m t Ë é ;  / 7 5B N \ j œ ,¦ Ø ,& <0 œ 9· ô 9  : !‡  › ­ º Ð ß !î  =9 =[ e q = =¿ Å Õ ==H>N ÿ9 o?y ¦>¬ 59; S ‡>   ª ° Ð ñ   # $0/G W07™ Ã7Î Ý/ú 7C7N ]/p ˜7ž ¤ ã7 ?/?X??ª?Ó?Þ í/÷ 0  S0m € † /±0· â ì %0 D7] „7¥ È ä F<Q 'znaupd.o/ 1189291780 1000 1000 100644 6944 ` ELFp4( U‰åWVSìÌ‹M ‹UèüÿÿÿËE‹u‰Mì‹M$‰Uð‹}‰Eà‹E<‰uè‹u0‰MØ‹Mð‰}ä‹U‰EÄ‹}4‰uÔ‹1‰UÜ‹UH…ö‰}ЉUÌ„Z‹³X‰u ‹»‹³ ‹‹,¸ºÁá‰D$h‹EÌÁæ‰T$d‹UDÁç‰D$`‹E8‰T$\‹UЉD$X‰T$T‹EÄ“4‰T$LLð‰L$P‹UÄDð‰D$HLð»0‰L$DÁe ‹E ‰|$<‹‹‹}(tðÁáDð‰t$@‹u,‹D‰|$0‹} “(‰D$8ƒ$‰t$4³<‰MÀ‰L$,‰D$(ƒT‰T$$“L‰t$ ‰|$‹MÜ‹uä‹}è‰L$‹Mì‰E¼‰D$‹Eð‰T$‰t$ ‰|$‰L$‰$èüÿÿÿ‹Uð‹ƒøtƒøc„¥ÄÌ[^_]˳T‹}Ô‰wÄÌ[^_]Ãvèüÿÿÿ‹‰ $èüÿÿÿ‹“¸¹‹rD‹UÔ‰ƒH‹Eè‹:‰³@‹r‰»$‹z‰³<‹0‰‹(¹ÿÿÿÿ…ö‰»DŽé‹Eà¹þÿÿÿ‹…Ҏ׋MØ‹9ÐŽê9ðâ…ÿ¹üÿÿÿŽµ‹}为‰D$ ³‰T$‰t$‰<$èüÿÿÿ…À…0‹M춌I‹“<¹öÿÿÿBÿƒø‡2J„‹‹H…ÉŽÝÙƒ‹UÜÝÙÉÚéßàžƒ¤ƒ»$v ¸‰ƒ$‹uØ‹Mà‹‰U¬‹9‹E¬‰»L)ø‰ƒT‹u¬‹U¬¯ö<’ vT9ÿ…Òx%݃‹EÄ݃ƒÀÙÉÝPøÙÉ݃ÀJyñÝØÝØ‹M¬¿‰»‰‹0‰‹4¯É‰M¨A‰M ‰‹X‹}¬ω»‹u¬þ‰³ ‹M¨ñ‰‹,‹U¬R‰EÈ‹UÈ‹E¨ЋUÐȉƒP‰B ÇB‹E ‰r‰z‰B‰J4éƒüÿÿ€}³G…Ýþÿÿ¹õÿÿÿv‹}Ì‹Uð‰ÇcÄÌ[^_]ô&‹}̹ýÿÿÿëÙ¶‹UÔ‹‹D‹ƒT‰J‹‹‰B‰M¸‹1‰r ‹y‰z$‹A‰B(‹UÌ‹…Àˆýÿÿƒø„*‹“@…ÒŽÝ»¾)ƒ‰|$‹»‰t$w‰t$ ‹MÀ‰L$‰E´‰D$‰<$èüÿÿÿ‰t$ ‹Dº0‰L$‰T$‹E¼‰D$‹U´‰<$‰T$èüÿÿÿ‰t$ ¹ƒt‰L$‹‹X‰D$‹UÄÁáDð‰D$‹U¼‰<$‰T$èüÿÿÿ‰t$ ¹!ƒ”‰L$‹‹‰D$‹UÄÁáDð‰D$‹u¼‰<$‰t$èüÿÿÿ‹‰ $èüÿÿÿÙƒ‹E¸Ø«ÙXL‹“@…ÒŽýûÿÿ»‰<$èüÿÿÿèüÿÿÿ‹‰ $èüÿÿÿº‰T$‹uÀ‰t$³‰4$èüÿÿÿ¸‰D$‹}¸‰4$‰|$¿èüÿÿÿ¹‰L$‹U¸‰4$B‰D$èüÿÿÿ‰|$‹M¸‰4$Q‰T$èüÿÿÿ¸‰D$‹}¸‰4$O ‰L$èüÿÿÿº‰T$‹E¸‰4$x‰|$¿èüÿÿÿ¹‰L$‹U¸‰4$Bh‰D$èüÿÿÿ‰|$‹M¸‰4$Ql‰T$èüÿÿÿ¸‰D$‹}¸‰4$OL‰L$èüÿÿÿº‰T$‹E¸‰4$xP‰|$¿èüÿÿÿ¹‰L$‹U¸‰4$BT‰D$èüÿÿÿ‰|$‹M¸‰4$Qt‰T$èüÿÿÿ¸‰D$‹}¸‰4$Op‰L$èüÿÿÿº‰T$‹E¸‰4$xX‰|$¿èüÿÿÿ¹‰L$‹U¸‰4$B\‰D$èüÿÿÿ‰|$‹M¸‰4$A`‰D$èüÿÿÿº‰T$‹}¸‰4$Od‰L$èüÿÿÿ¸‰D$‹U¸‰4$zx‰|$èüÿÿÿèüÿÿÿéìùÿÿÇéËüÿÿ‹M亾‰T$ »µ‰t$‰|$‰ $èüÿÿÿ…À„¡úÿÿ‹Eä‹·¾‰t$ ¿‰|$‰L$‰$èüÿÿÿ…À„rúÿÿ‹U乃¹‰L$¿‰|$ ‰D$‰$èüÿÿÿ…À„Cúÿÿ‹u乸‰L$ “»‰D$‰T$‰4$èüÿÿÿ…À„úÿÿ‹}为‰D$ ³½‰T$‰t$‰<$èüÿÿÿ…À¹ûÿÿÿ…fûÿÿéÛùÿÿ‹¿¾‰t$‰ $èüÿÿÿ‹}ÜÝé;úÿÿ¾‰³Héúÿÿ(/,/,5X,=============================================,/,5X,= Complex implicit Arnoldi update code =,/,5X,= Version Number: , 2.3,21X, =,/,5X,= Version Date: , 07/31/96,16X, =,/,5X,=============================================,/,5X,= Summary of timing statistics =,/,5X,=============================================,/,/)(5X,Total number update iterations = ,I5,/,5X,Total number of OP*x operations = ,I5,/,5X,Total number of B*x operations = ,I5,/,5X,Total number of reorthogonalization steps = ,I5,/,5X,Total number of iterative refinement steps = ,I5,/,5X,Total number of restart steps = ,I5,/,5X,Total time in user OP*x operation = ,F12.6,/,5X,Total time in user B*x operation = ,F12.6,/,5X,Total time in Arnoldi update routine = ,F12.6,/,5X,Total time in naup2 routine = ,F12.6,/,5X,Total time in basic Arnoldi iteration loop = ,F12.6,/,5X,Total time in reorthogonalization phase = ,F12.6,/,5X,Total time in (re)start vector generation = ,F12.6,/,5X,Total time in Hessenberg eig. subproblem = ,F12.6,/,5X,Total time in getting the shifts = ,F12.6,/,5X,Total time in applying the shifts = ,F12.6,/,5X,Total time in convergence testing = ,F12.6,/,5X,Total time in computing final Ritz vectors = ,F12.6,/)€LM_naupd: Number of update iterations taken_naupd: Number of wanted "converged" Ritz values_naupd: The final Ritz values_naupd: Associated Ritz estimatesSMLRSRLISIEpsMach‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rel.data.rel.local.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@à ÈH % • +¸\4¸(0  DàÆL¨Y°€´´#×™Èp( 8ñÿ  #(16 ;$D(L,R0Y4`8i<q@{D…H‹L“P›T¡X©»iІ ÷ü à  !7?GO `òÿV\ |òÿdkry€‡znaupd.ft0.0t1.1t2.2t3.3t4.4t5.5bounds.6ih.7iq.8ishift.9iupd.10iw.11ldh.12ldq.13levec.14mode.15msglvl.16mxiter.17nb.18nev0.19next.20np.21ritz.22__g77_cilist_0.24__g77_format_1000.23__g77_cilist_1.26__g77_format_1100.25.LC6.LC10znaupd___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_znaup2_zstatn_arscnd_debug_s_cmptiming_ivout_zvout_s_wsfee_wsfedo_fiodlamch_) *h q w } ½ Þ ó   % / @ J „+¨ Á,Ç Ï-Õ.ë ö ÿ    n !~/É ç õ %   1 9 V !_ !ƒ ‰  Ÿ ª µ À Ü E K T0‡ • !  &ª.Ë1Õ !ø1 ! 22A !K l2r z-€ ‰ ’   ¨3­4³ »3Ñ &Ù5ö55'5B5b5}5“5®5Î5é5ÿ55:5U5k5†5¡5¦4Í !Ý/î ! /" !;/Z !j/‰ !™/± !Â6×   zneigh.o/ 1189291780 1000 1000 100644 3212 ` ELFx4( U‰åWVS윋E‹UèüÿÿÿËM ‹u ‰EÌ‹E$‰UÈ‹U(‰M°‹M0‰uЋ}‰EÄ‹EĉU¬‹u‰MÀ‹‹‰U¼‰ $èüÿÿÿ‹ƒ‰E´‹PPƒú‰U¸à‹Mи‰D$‰L$‹U¬‰t$ ³‰T$‰|$‰L$‰L$‰4$èüÿÿÿ‹Uĸ‰D$ƒ‰T$‹M°“‰T$ ‰4$‰L$‹MЉD$‰L$‰L$èüÿÿÿ‹EÀ‹uÄ‹MЉD$0ƒ‰t$,‹U°‰L$$‹uÌ‹MЉT$(‰E¨‰t$‰|$‰D$ ‹U¬‰L$‰T$‹E¨‰L$‰D$ ‰D$‰$èüÿÿÿ‹uÀ‹>…ÿtHÄœ[^_]Ë(º+‰T$‹UЉL$‹M´‰|$‰t$ A‰D$‰T$‰T$‰ $èüÿÿÿéãþÿÿ‹M¨‹uÈ‹}ĉL$‹EЉt$ ‰|$‹‹U°‹}ÐÁátà‰t$‰<$èüÿÿÿƒ}¸‹}À¾º‰t$<‹E,‹uЉ|$8‹}ĉT$@‰D$4‹‹M¬‰|$$¯Ò‰t$,‹}Љt$(ÁâʉT$0‹UЋE°‰|$Mà‰T$“S‰D$ EÔ‰L$‹u¬‹W‰|$ ‰D$‰t$‰T$‰ $èüÿÿÿ‹uÀ‹>…ÿ…åþÿÿ‹MЋ‰ÇOxj‹E¼u؉u¤‹u°Áà‰E ë ‹E¨‰t$‹MЉD$‰ $èüÿÿÿØ»‹U¨‰t$‹MЉT$ ‹E¤Ý]؉D$‰ $èüÿÿÿ‹U ÖOy¼‹}Ћƒ}¸Ä‹M¨Áà‹UÈ‹uЉL$‹MЉT$ ‰t$‹}°‰ $D8ð‰D$èüÿÿÿ‹U¨‹uÈ‹}‰T$ ‹EЉt$‰|$‰$èüÿÿÿƒ}¸Úƒ‰$èüÿÿÿÙƒ‹‹Ø«ØAXÙYXÄœ[^_]Ó\¸*‹}ȉD$‹EЉT$‹M´‰|$‰D$q‰t$ ‹U´‰$èüÿÿÿé(þÿÿ‹M¨Áà‹uĉL$‹U¬‰t$‹Mгˆ‰T$ ‹}°‰ $D8ð‰D$èüÿÿÿ‰t$º0‹MЉT$‹“z‰|$ ‹E¬‰L$‰$‰D$èüÿÿÿ‹uЋéÎþÿÿ³¸‹UÌ¿‰t$‹³‹EЉ|$~‰|$ ‰T$‰D$‰4$èüÿÿÿ‰|$ ‹Eй/‰L$‹}È“Ô‰T$‰D$‰|$‰4$èüÿÿÿé¾þÿÿAllð?_neigh: Entering upper Hessenberg matrix H BackRight_neigh: last row of the Schur matrix for H_neigh: Last row of the eigenvector matrix for H_neigh: The eigenvalues of H_neigh: Ritz estimates for the eigenvalues of H€?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@} T 8 %À+À0À8ÄEÌlÐ|Ð#ó…€   Ãñÿ  #(- 2}:Qgo `òÿv~†Ž•œ¤¬´ |òÿ¼zneigh.ft0.0t1.1t2.2t3.3t4.4t5.5.LC4.LC8zneigh___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_debug_zlacpy_zlaset_zlahqr_zmout_zcopy_ztrevc_dznrm2_zdscal_timing_zvout_ N Y_Ž ¦¸ Å ä÷ =W ‰Á( < T¢¨ È -= EK QW n ž À ×í  )G ` t zneupd.o/ 1189291780 1000 1000 100644 10828 ` ELF 4( U‰åWVSì ‹}‹u èüÿÿÿËM‹E‰½@ÿÿÿ‹U‰µ<ÿÿÿ‹}‰8ÿÿÿ‹u ‰…4ÿÿÿ‹M$‰•0ÿÿÿ‹E(‰½,ÿÿÿ‹U,‰µ(ÿÿÿ‹}0‰Äþÿÿ‹u4‰…$ÿÿÿ‹M8‰• ÿÿÿ‹E@‰½ÿÿÿ‹UD‰µÿÿÿ‰ÿÿÿ‰…ÿÿÿ‰• ÿÿÿ‹}H‹uX‹Md‹UL‰½ÿÿÿ‹ƒ‰µÔþÿÿ‹}P‰ÿÿÿ‹p\‹J‹…ÿÿÿ‰µèþÿÿ‹r“‰M€¹ljL$‰$èüÿÿÿ݃ÙÉÝ$Ý\$èüÿÿÿ‹E€Ýxþÿÿ…ÀŽÓ‹• ÿÿÿ¸ÿÿÿÿ‹ …É~/‹•ÿÿÿ‹…ÀŽ¼‹•ÿÿÿ‹9‰•Dþÿÿ~9ÊŽ¬¸ýÿÿÿ‰…xÿÿÿVÿƒú†4ƒþ„N ¸öÿÿÿN‰…xÿÿÿ„G‹…xÿÿÿ…Àt‹½ÿÿÿ‰Ä [^_]ô&‹G‹•ÿÿÿ‹O‰…äþÿÿ‹w‹‰ÿÿÿ‰µüþÿÿ‰ÂÁ‰ôþÿÿ¯ÐÁ‰øþÿÿÁ‰…tÿÿÿ‹µøþÿÿ‰ìþÿÿщðþÿÿ‹ôþÿÿ‰…|ÿÿÿ‰w(‹µðþÿÿ‰O ‹ìþÿÿ‰w0‰O,‹O4‹µÔþÿÿÊЉ…Üþÿÿ‹…üþÿÿ‰•àþÿÿÁàðÝ@HÝ]°ÝAÝ]¸ÝƒÝX݃ÝYƒ½èþÿÿL‹…@ÿÿÿ‹…É„–‹µÿÿÿ1ÿº‰½Øþÿÿ‹‰•Lÿÿÿ‰@þÿÿIxP‹…ÿÿÿ¾‹½Ôþÿÿ‹•8ÿÿÿÁàD8t&VFÛ$ƒÄÇ@èÇ@ìÝXàƒÀǃÂIy؉µLÿÿÿ‹µÿÿÿ¿‹)@þÿÿÇE¨‹•@þÿÿ‰U¬‰|$‹…ÿÿÿ‹ÔþÿÿÁàtðE¬‰µ¨þÿÿ‰t$‹•àþÿÿ‹µÿÿÿÁâ| ð‹•ÿÿÿ‰½ þÿÿM¨‰|$‰D$ ‰t$‰T$‰ $èüÿÿÿƒ½èþÿÿÈÇE„‹•ÿÿÿ¹‹‰Lÿÿÿ‰ÇOˆAM u˜‰˜þÿÿ‰µœþÿÿé€ÝPÿÿÿ‹•ÿÿÿ‹…ÿÿÿ‹ ‹•LÿÿÿÈ‹Ôþÿÿ)ÐÁàÝDð‹E€Ù½Jÿÿÿ·µJÿÿÿfÎ f‰µHÿÿÿ9E„Ù­HÿÿÿÛDÿÿÿÙ­Jÿÿÿ‹µDÿÿÿŒ5JO‰Lÿÿÿˆ²‹•ÿÿÿ‹‹àþÿÿ‹µLÿÿÿ‹•ÔþÿÿÈ)ð‹˜þÿÿÁàÐÝ@øÝ] ‰L$‹µœþÿÿÝ@ðÝ]˜‰4$èüÿÿÿÝ…xþÿÿÙÉÝ•PÿÿÿÝéßàž‚(ÿÿÿÝØé'ÿÿÿ¹ºƒ ‰L$ M؉T$‰D$‰ $èüÿÿÿN…¹üÿÿ‹µ$ÿÿÿ€>G…ªüÿÿºõÿÿÿ‰•xÿÿÿéšüÿÿ¸òÿÿÿécüÿÿ¸þÿÿÿéYüÿÿ1ɸº‰xÿÿÿ‹&‰D$ ‹…ÿÿÿ‰T$‰L$‰$èüÿÿÿ…À…Ð ‹$ÿÿÿ¶ÙÁØñÜÊÙÊÞÁÙÅØÊÙÊØÍÙÊØÅÙÊØæÙÉÙÊÙÉÙÉØòÙɃÂÞòØÃÙÉØÂÙÉÝÝ^ƒÆIx6ÝBøÝÙÁÙÁÙÉÙáÙÉÙáÚéßàžwªÙÀØòÙÅÙÊØÉÙÊØÉÙÉØÏÙÊÞÃØÆÙÉØíë¬ÝØÝØÝØÝغ¿‰T$ ‰|$‹µdþÿÿ‰t$‹`þÿÿ‰ $èüÿÿÿ…À„¿ƒ½èþÿÿ ‹…@ÿÿÿ‹…É„+ùÿÿ‹•<ÿÿÿ€:A…ùÿÿ¸¹‰D$ ‰L$‹½”þÿÿ‰|$‹µ`þÿÿ‰4$èüÿÿÿ…À…êøÿÿ‹u€º‰•Lÿÿÿ‰ñIˆKÙƒ¾‹½|ÿÿÿ‰½Àþÿÿ鲊ÒÝéßàžz„“‹•Äþÿÿ‰ðÁà|ð‹•ÀþÿÿFÿ¯Â‹•ÿÿÿ‹•ðþÿÿЋ•ÔþÿÿÁàÐÝ@à‹•ôþÿÿÝ@èòÁâ•ÔþÿÿÝBàÝBèÙÁÙÁÙÉÙáÙÉÙáÚéßàž†° ÙÁØñÜÊÙÊÞÁÙÃØÊÙÊØËÙÊÞÃÙÉÙÊÙËÞêÜúÞùÙÉÝÝ_FI‰Æˆu‹•ôþÿÿ‹½ÔþÿÿòÁâúÝBàÝBèÙÉÝêßàž„(ÿÿÿÝØé4ÿÿÿ³@¿*‰t$‹³‰|$~‰|$ ‹…àþÿÿ‹•Ôþÿÿ‰4$ÁàLð‰L$‹…ÿÿÿ‰D$èüÿÿÿ‰|$ ‹lº-‰L$‹½ÿÿÿ‰T$‹•Üþÿÿ‹…Ôþÿÿ‰|$ÁâLð‰L$‰4$èüÿÿÿé&øÿÿ³œ¿)‹…ÿÿÿ‰t$‹³‰|$~‰|$ ‹• þÿÿ‰D$‰4$‰T$èüÿÿÿ‰|$ ¹0“ȉL$‹…ÿÿÿ‰T$‹½¨þÿÿ‰D$‰4$‰|$èüÿÿÿéÄøÿÿ¹ºƒ(‰L$ u؉T$‰D$‰4$èüÿÿÿé˜öÿÿ‹…@ÿÿÿ‹0…ö…·‹½ÿÿÿ‹Iˆ!üÿÿ‹…øþÿÿ‹•ôþÿÿ‹µÔþÿÿÁàÁâ|0øT2øëkÙÃØóÙÂØÉÙÅØÊÙÉØÃÙËÞÊØÄÙÄÙáÙÊÞäÜúÞûÙÄÙáÙÉÚéßàž†©ÙÉÙÃØóÜÌÙÌÞÃÙÁØÌÙÌØÉÙÌÞÁÙÉÙÊÙËÞâƒÂØòÙÉÞòÝ_ø݃ÇIˆ”ûÿÿÝBøÝÝGøÙÂÙÂÝÙÊÙáÙÉÙáÚéßàž‡tÿÿÿÙÂØôÙÁØÉÙÄØÊÙÉØÄÙÌÞÊØÅÙÄÙáÙËÞâÜûÞùÙÄÙáÙÊÝêßàÝÙž‡tÿÿÿÙÂØôÜËÙÁØÉÙÌÞÅÙËØÂÙÊÞËéuÿÿÿÙÉëჽèþÿÿŽAüÿÿ³ø‹•4ÿÿÿ¿‰t$‹³‰|$‰T$~‰|$ ‹…Xþÿÿ‰4$‰D$èüÿÿÿ‰|$ ¹"“‰L$‰T$‹…ÔþÿÿU€Á¥øþÿÿ‹½øþÿÿLð‰L$‰•Xþÿÿ‰T$‰4$èüÿÿÿé¹ûÿÿ‹…ÿÿÿ‹‰Ê¯ÑRˆ‹E\9g¸ùÿÿÿéôÿÿ³<¹'}„‰t$‹³‰L$F‰…tþÿÿ‰|$»‰D$ ‰|$‰4$èüÿÿÿº)‹d‰T$U€‰L$‹…tþÿÿ‰T$‰|$‰D$ ‰4$èüÿÿÿé·øÿÿ‹‰þÿÿ‰L$‹…ìþÿÿ‹µÔþÿÿ‰L$Áà‹ÿÿÿ|0ð‰|$ Á¥üþÿÿ‹•üþÿÿD2ð‰D$uÔ‹‹…tÿÿÿ¯Â‰EÔ‰4$èüÿÿÿ•|ÿÿÿ¸‰D$ƒ0‰•¼þÿÿ‰T$‹µðþÿÿ“‹ÔþÿÿÁætð‰t$‹ÿÿÿ‰…Œþÿÿ‰D$ƒ‰T$ ‰L$‰L$‰…°þÿÿ‰$èüÿÿÿ•xÿÿÿ‰•´þÿÿ‰T$0‹¼þÿÿ‰t$(‹µÿÿÿ‰L$,‰t$$‹…þÿÿ‰D$ ‹ôþÿÿ‹•ÔþÿÿÁáDðtÿÿÿ‰…Ðþÿÿ‹•ÿÿÿ‰D$‰¸þÿÿ‰L$‰|$‰t$‹µþÿÿ‰T$‰t$ ‰t$‰4$èüÿÿÿ‰t$‹…øþÿÿ‹ÔþÿÿÁàtð‰t$ ‹•¼þÿÿ‰T$‹•ÿÿÿ‹…ðþÿÿ‹ È‹Ôþÿÿ‰$ÁàDà‰D$èüÿÿÿ‹…xÿÿÿ…Àt‹½ÿÿÿÇøÿÿÿéòÿÿƒ½èþÿÿÔ‹µØþÿÿ}€‰½lþÿÿ…ö…G‹µþÿÿ‰t$‹øþÿÿ‹µÔþÿÿÁáD1ð‰D$ ‹•¼þÿÿ‰T$‹•ÿÿÿ‹ðþÿÿ‹:‰$ùÁáD1à¿u؉D$èüÿÿÿ‰|$ ƒ ¹‰L$‰…dþÿÿ‰D$‰µ`þÿÿ‰4$èüÿÿÿ…À„‹…´þÿÿ‹½ÿÿÿ‰D$‹7‹•ÄþÿÿÁæÖ‰t$‹Äþÿÿ‰L$‹…¼þÿÿ‹ÿÿÿ‰D$ ‹µðþÿÿ‹½ÔþÿÿÁæt>ð¿‰t$‹•lþÿÿ‰ $‰T$èüÿÿÿ‰|$0‹ ÿÿÿ•xÿÿÿ¸ ‰D$4‹ET‰•\þÿÿ‰T$,‹9‹•ÿÿÿ‹ ÿÿÿÁçlj|$(½|ÿÿÿ‰T$$‹•ÿÿÿ‰L$ ‹…Äþÿÿ‹ ÿÿÿ‰D$ƒ‰½¬þÿÿ‰|$»›‰t$u€‰t$‰T$ ‰L$‰D$‰½¤þÿÿ‰<$èüÿÿÿ‹,ÿÿÿº‹…0ÿÿÿ‰T$‹½ÿÿÿ‹• ÿÿÿ‰L$‹ ÿÿÿ‰T$ ‰D$‰|$‰µXþÿÿ‰t$‰L$‹…°þÿÿ‰$èüÿÿÿ‹u€ºNˆá‹Xþÿÿ» ‰½@þÿÿ‰€þÿÿë NQˆ½‰•Lÿÿÿ‹½|ÿÿÿBÿÙî‰Ñ¯Ç‹½ðþÿÿÐø‹½ÔþÿÿÁàÝD8àÙÉÚéßàžvÀ‹¬þÿÿ‰L$ ‹…ìþÿÿÐÁàL8à‰L$‹•@þÿÿ‰T$‹½Xþÿÿ‰<$èüÿÿÿ‹…þÿÿ‰D$ ‹…Lÿÿÿ‹|ÿÿÿ‹•ìþÿÿH‹½Ôþÿÿ¯ÁÐÁàD8ð‰D$‹@þÿÿ‰L$‹•€þÿÿ‰•Xþÿÿ‰$èüÿÿÿ‹Lÿÿÿé/ÿÿÿ³°‹…4ÿÿÿ¿"‰t$‹³‰|$‰D$~‰|$ ‹Xþÿÿ‰4$‰L$èüÿÿÿ‰|$ º8ƒÔ‰T$‰D$‹½ÔþÿÿE€Á¥øþÿÿ‹øþÿÿT9ð‰T$‰…Xþÿÿ‰D$éúÿÿ‹•þÿÿu°‰T$ ‹øþÿÿ‹½Ôþÿÿ‰t$‹•ÿÿÿÁáD9ð‰D$‰$èüÿÿÿéyôÿÿ‹þÿÿ}°‰L$ ‹…øþÿÿ‹µÔþÿÿ‰|$‹ÿÿÿÁàT0ð‰T$‰ $èüÿÿÿéøÿÿ‹µ<ÿÿÿ€>A„·‰•Lÿÿÿéâóÿÿº¹ƒ ‰T$ ‹•ÿÿÿ‰L$‰D$‰$èüÿÿÿ…À„þñÿÿ¸º‹‰D$ ‹…ÿÿÿ‰T$‰L$‰$èüÿÿÿ…À„Ìñÿÿ¹¸“‰L$ ‹ÿÿÿ‰D$‰T$‰ $èüÿÿÿ…À„šñÿÿº¹ƒ‰T$ ‹•ÿÿÿ‰L$‰D$‰$èüÿÿÿ…À„hñÿÿ¸º‹‰D$ ‹…ÿÿÿ‰T$‰L$‰$èüÿÿÿ…À„6ñÿÿ¸ûÿÿÿéKíÿÿÙÀØòÜÉÙÃØÉÙÊÞÃÙÉØÄÙÌÞÉéQõÿÿ‹<ÿÿÿ¶ð‰D$ ‹µþÿÿEÀ‰D$‰T$“Ô‰t$Á¥ìþÿÿ‹µìþÿÿ‰L$ ‰T$D>ð‹½8ÿÿÿ‰D$‰|$‹µ¤þÿÿ‰4$èüÿÿÿ‹xÿÿÿ…É„µ‹½ÿÿÿÇ÷ÿÿÿéÒéÿÿ‹µþÿÿ‹½4ÿÿÿ‰t$‰|$ ‰t$‹ôþÿÿ‹•ÔþÿÿÁáDð‰D$‹½lþÿÿ‰<$èüÿÿÿé ÷ÿÿÝ؉…Lÿÿÿ‹½,ÿÿÿ‹µ0ÿÿÿ‹U<‰|$ »0‰t$‹…þÿÿ‰D$‹Äþÿÿ‰D$‰T$ ‰L$‹ ÿÿÿ‰|$‹µXþÿÿ‰ $‰t$èüÿÿÿé.éÿÿ‹U€¸‰…Lÿÿÿ‰ÖNˆ2‹•øþÿÿ½Lÿÿÿ‹Ôþÿÿ‰½ˆþÿÿ…PÿÿÿÁ≅„þÿÿ| ð‹…þÿÿ‰D$‹…Lÿÿÿ‹•|ÿÿÿ‹ðþÿÿH¯Â‹•ÔþÿÿÈ‹ÿÿÿÁàDð‰D$‰ $èüÿÿÿØ»‹…þÿÿÝPÿÿÿ‰D$ ‹…Lÿÿÿ‹•|ÿÿÿ‹ðþÿÿH¯Â‹•ÔþÿÿÈÁàDð‰D$‹„þÿÿ‹…ÿÿÿ‰L$‰$èüÿÿÿ‹•þÿÿ‰T$‹•Lÿÿÿ‹|ÿÿÿBÿ¯Á‹ðþÿÿÁâÈ‹ÔþÿÿÁàDð‰D$‹…þÿÿ‰|$‰D$ ‹ˆþÿÿ‰L$‹…ÄþÿÿLð‰ $èüÿÿÿÿ…LÿÿÿN‰ùþÿÿƒ½èþÿÿù‹þÿÿ‰L$‹…øþÿÿ‹½Ôþÿÿ‰L$ÁàT8ð‰T$ ¿ ‹µÄþÿÿ‰t$‹…Xþÿÿ¾‰$èüÿÿÿ‰|$4º‹…,ÿÿÿ‰T$8‹•0ÿÿÿ¹‰D$(‰L$0‰t$,‰T$$‹½¬þÿÿ‰|$ ‹µðþÿÿ}€‹ÔþÿÿÁæDð‰D$‹ ÿÿÿ³Ú‹•Œþÿÿƒâ‰T$“Xþÿÿ‰|$‰L$‰t$ ‰D$‰T$‹½¤þÿÿ‰<$èüÿÿÿéDìÿÿ‹½ÿÿÿÇéßæÿÿ‹þÿÿ‹•ÿÿÿ‰L$‹µøþÿÿ‹ÔþÿÿÁætð‰t$ ‹…¬þÿÿ‰D$‹:‹…ðþÿÿøÁà|à‰|$‹…Xþÿÿ»ô‰$èüÿÿÿ‰|$‹»º0‰T$O‰Tþÿÿ‰t$u€‰L$ ‰µXþÿÿ‰t$‰<$èüÿÿÿƒ½èþÿÿŽgþÿÿ³$¹$‰L$‰t$‹…Tþÿÿ‰D$‹•¬þÿÿ‰T$‹µðþÿÿ‹Ôþÿÿ‰<$‹•ÿÿÿÁæDð‰D$ ‰T$‰T$èüÿÿÿéþÿÿEpsilon-MachineREGULRLMSHIFTIð?_neupd: Ritz values passed in from _NAUPD._neupd: Ritz estimates passed in from _NAUPD._neupd: Ritz values after calling _NGETS._neupd: Ritz value indices after calling _NGETS._neupd: Converged Ritz values._neupd: Associated Ritz estimates._neupd: Number of specified eigenvalues_neupd: Number of "converged" eigenvaluesAllNotransposeRightð¿€_neupd: Untransformed Ritz values._neupd: Ritz estimates of the untransformed Ritz values.SMLRSRLISINoneV_neupd: Eigenvalues of H--reordered_neupd: Triangular matrix after re-ordering_neupd: Eigenvalues of H_neupd: Last row of the Schur vector matrix_neupd: The upper triangular matrix SelectNon-unitNo transposeUpper_neupd: Last row of the eigenvector matrix for T_neupd: The eigenvector matrix for TUUUUUUå?€?‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst8.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@¸ |&Ð %ø+ø0øH8@EH RTyX‰X#{’@"  P%,ñÿ  # (-39 ?¸G^t `òÿ{ƒ‡—ž¤«²¹ÁÉÑÙáèð÷ÿ$ |òÿzneupd.ft0.0t1.1t2.2t3.3t4.4t5.5.LC1.LC17.LC13.LC32zneupd___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_debug_dlamch_powzngets_dlapy2_s_copys_cmpzcopy_zvout_ivout_zlaset_zlahqr_zgeqr2_zunm2r_zlacpy_zscal_ztrsen_zmout_ztrevc_zgeru_dznrm2_zdscal_zdotc_ztrmm_timing_ ²Ü öü  ] f {± È 4Š( `‘Üè ; `x Š J¨Í È ×    K  V k Œ  › ¿  Ô ë $ 9 Z  i ¡  Ô æ ý  ! = !H ¡ ¶ Ì ó "”#âw ¢$z Š ¯%&  'ñ' 8 G ²'í' 6N h€ š² Ìä þ  /(O d… ˜ Ù)äï , 7 e } ³)p ©*+ g+ï,õ F-¨. g s } ¥/  N a ¯)zngets.o/ 1189291780 1000 1000 100644 2100 ` ELFL4( U‰åWVSƒì<‹M‹UèüÿÿÿË}³‹E‰Mä‰Uà‰}؉4$‰EÜèüÿÿÿ‹‹º‹EØ‹}܉MÔ‹qX‹Mà‰T$‹Uä‰D$‰|$ ‹9Mð‹‹U ‰L$lj}ð»‰|$‰$èüÿÿÿ‹Eƒ8„ƒ‰$èüÿÿÿÙƒ…ö‹‹Ø«ØA\ÙY\ŽÛ‰|$‹MÔ³‰t$‹E争T$q‰t$ ‰ $‰D$èüÿÿÿ‰|$‹Eຠ‰T$‹}Ô‹‰L$‰t$ ‰<$‰D$èüÿÿÿ‰t$ ‹Eܺ(‰T$‹}à‹‰L$‹Uä‰D$‹‹ ‹UÔ}ì‰|$ȉ$‰Eìèüÿÿÿ‰t$ ‹}ع8‰L$‹uàƒD‰D$‹Uä‰|$‹}è‹ ‰|$‹uÔȉEè‰4$èüÿÿÿƒÄ<[^_]É|$‹Eܺ‰T$‹MØ‹Uà‰D$ƒ|‰L$ ‰T$‰$èüÿÿÿéºþÿÿ_ngets: KEV is_ngets: NP is_ngets: Eigenvalues of current H matrix _ngets: Ritz estimates of the current KEV+NP Ritz valuesSM‹$ÃGCC: (GNU) 3.4.6 (Debian 3.4.6-6).symtab.strtab.shstrtab.rel.text.data.bss.rodata.rodata.cst4.gnu.linkonce.t.__i686.get_pc_thunk.bx.note.GNU-stack.comment@Ú „° %+0~8œE l¤|¤#Ç…T   ôñÿ  #( - `òÿ4 |òÿ<ÚD[qyˆzngets.ft0.0t1.1t2.2t3.3t4.4t5.5.LC0debug_timing_zngets___i686.get_pc_thunk.bx_GLOBAL_OFFSET_TABLE_arscnd_zsortc_ivout_zvout_  6<x „– ž¤ ¬² Ë î 4 Zs ™Á Ñzgetv0.o/ 1189291780 1000 1000 100644 4664 ` ELFœ 4( U‰åWVS켋E ‹UèüÿÿÿË}‹u‰E˜‹E(‰Uœ‹M ‰}”‹U$‰u‹},‰E„‹ƒ‰MŒ‹u0‰Uˆ‹M4‰}€‹U8…À‰µ|ÿÿÿ‰tÿÿÿ‰•xÿÿÿt4º¸¿‰“ ¾1ɉƒ$‰»(‰³,‰‹‹Mœ‹1…ö„Ë‹…É„ù‹M˜¶G…Õûÿÿ‹³‹U”‹½|ÿÿÿÿ³Ç‹‹U„@‰G‹tÿÿÿ‰t$‹E”‰t$‰L$ ‰T$‰$èüÿÿÿ‹}œÇÿÿÿÿé6ÿÿÿv¾+‹E„»Ä‰t$‹³‹M”‰|$V‰T$ ‰D$‰L$‰4$èüÿÿÿéÉþÿÿ³ ‰4$èüÿÿÿÙƒ‹³‹Ø« ØFhÙ^h‰ $èüÿÿÿ‹U˜¸‰ƒ¶ 0: printing is done with 132 columns. mgetv0 > 0: print residual vector generated. ====================================== === Specific to the symmetric code === ====================================== msaupd > 0: *Print the number of iterations taken, number of "converged" eigenvalues, final Ritz values and corresponding Ritz estimates. *Print various timing statistics. msaup2 > 0: *Print major iteration number, number of "converged" Ritz values on exit, B-norm of the residual vector of length NCV factorization, B-norm of the residual vector of length NEV factorization, residual norm before exit, Ritz values and corresponding Ritz estimates before exit. msaup2 > 1: print number of unreduced submatrices, Ritz values and corresponding Ritz estimates of the current T matrix, actual values for NEV and NP, wanted Ritz values and corresponding Ritz estimates, shifts selected. msaup2 > 2: print "unwanted" Ritz values and corresponding Ritz estimates, order NCV matrix T (diagonal and off-diagonal), unwanted Ritz values and error bounds. msaitr > 0: print iteration number, residual norm, restart info print if an off diagonal element of T became negative. msaitr > 1: print the final matrix T. msaitr > 2: print Arnoldi vector no. generate at iteration j, b-norm of residual vector at each iteration, print rnorm and rnorm1 for iterative refinement, print wnorm and rnorm used for Re-orthogonalization, V^T * B * (resid/B-norm(resid)), print the results of whether the current residual vector is orthogonal to the current Lanczos basis. msaitr > 3: print the matrix T at each iteration. print the residual vector and arnoldi vectors. mseigt > 0: print the current matrix T. msgets > 0: print NEV and NP, eigenvalues of and corresponding Ritz estimates of the current T matrix. msapps > 0: print information about deflation at row/column no. msapps > 1: print initial matrix T print sigmak, betak and matrix T after all shifts msapps > 2: print the matrix T after the application of each shift. msapps > 3: updated residual for next iteration. mseupd > 1: print eigenvalues of the final T matrix, the last row of the eigenvector matrix for T, if reordered, reordered last row of the eigenvector matrix, reordered NCV Ritz values of the final T matrix, if type = 'REGULAR', untransformed "converged" Ritz values and corresponding Ritz estimates, NCV Ritz values of the final T matrix, last row of the eigenvector matrix for T, if reordered, reordered last row of the eigenvector matrix, reordered NCV Ritz values of the final T. mseupd > 2: print the matrix T. ========================================= === Specific to the nonsymmetric code === ========================================= mnaupd > 0: *Print the number of iterations taken, number of "converged" eigenvalues, real and imaginary parts of the converged Ritz values and their corresponding Ritz estimates, *Print various timing statistics. mnaup2 > 0: *Print major iteration number. *Print the number of "converged" Ritz values on exit, and the real and imaginary parts of the "converged" Ritz values and corresponding Ritz estimates. mnaup2 > 1: *Print the length of the Arnoldi Factorization, and the B-norm of its residual vector. *Print NEV and NP, real and imaginary parts of the "wanted" Ritz values and associated Ritz estimates at each iteration. *Print the B-norm of the residual of the compressed factorization and the compressed upper Hessenberg matrix H. mnaup2 > 2: *Print the real and imaginary parts of all the Ritz values and associated Ritz estimates, NEV, NP, NUMCNV, NCONV. *Print the real and imaginary parts of the shifts. If the exact shift strategy is used, print the associated Ritz estimates of the shifts. *Print the real and imaginary parts of the Ritz values and the corresponding Ritz estimates obtained from _neigh. mnaitr > 0: *Print if a restart is needed. mnaitr > 1: *Print the number of Arnoldi vector being generated and the B-norm of the current residual. mnaitr > 2: *Print j-th column of the Hessenberg matrix H. *Print reorthogonalization and iterative refinement information, *Print the final upper Hessenberg matrix of order K+NEV. mnaitr > 3: *Print V^T*B*resid/(B-norm(resid)). mnaitr > 4: *Print current upper Hessenberg matrix. mnaitr > 5: *Print updated arnoldi vectors and the residual vector. mneigh > 1: *Print the last row of the Schur matrix for H, and the last row of the eigenvector matrix for H. mneigh > 2: *Print the entering upper Hessenberg matrix. *Print the real and imaginary part of eigenvalues of the current Hessenberg matrix, and associated Ritz estimates. mngets > 0: *Print the real and imaginary parts of the Ritz values of the Hessenberg matrix and their the corresponding error bounds, KEV, NP. mnapps > 0: *Print information about where deflation occured. mnapps > 1: *Print sigmak, betak, order of the final Hessenberg matrix, and the final compressed upper Hessenberg matrix. mnapps > 2: *Print implicit application of shift number, real and imaginary part of the shift. *Print the indices of the submatrix that the shift is applied. mnapps > 3: *Print the matrix H before and after the application of each shift, updated residual for next iteration. mnapps > 4: *Print the accumulated orthogonal Hessenberg matrix Q, updated matrix of Arnoldi vectors. mneupd > 0: *Print the number of converged Ritz values, B-norm of the residual, all NCV Ritz values and error bounds. mneupd > 1: *Print the final upper Hessenberg matrix computed by _naupd. *If Ritz vectors are requested, print real and imaginary parts of the eigenvalues and the last row of the Schur vectors as computed by _neupd. mneupd > 2: *If Ritz vectors are requested, print the threshold eigenvalue used for re-ordering. *If Ritz vectors are requested, print the number of eigenvalues to reorder and the number of converged Ritz values. *If Ritz vectors are requested, print the upper quasi-matrix computed by _neupd. *If Ritz vectors are requested, print the real and imaginary part of the Ritz values. *If Ritz vectors are requested, print the last row of the eigenvector matrix. *Print the NCV Ritz estimates in the original system. mneupd > 3: *Print the integer array of pointers. *If Ritz vectors are requested, print the eigenvector matrix. *If Ritz vectors are requested, print the reordered upper quasi-triangular matrix. mneupd > 4: *If Ritz vectors are requested, print the Q matrix of the QR factorization of the matrix representing the wanted invariant subspace. *If Ritz vectors are requested, print the Schur vectors. *If Ritz vectors are requested, print the reordered Schur vectors. ==================================== === Specific to the complex code === ==================================== mcaupd > 0: *Print the number of iterations taken, number of "converged" eigenvalues, the converged Ritz values and their corresponding Ritz estimates, *Print various timing statistics. mcaup2 > 0: *Print major iteration number. *Print the number of "converged" Ritz values on exit, and the "converged" Ritz values and corresponding Ritz estimates. mcaup2 > 1: *Print the length of the Arnoldi Factorization, and the B-norm of its residual vector. *Print NEV and NP, the "wanted" Ritz values and associated Ritz estimates at each iteration. *Print the B-norm of the residual of the compressed factorization and the compressed upper Hessenberg matrix H. mcaup2 > 2: *Print the all the Ritz values and associated Ritz estimates, NEV, NP, NUMCNV, NCONV. *Print the shifts. If the exact shift strategy is used, print the associated Ritz estimates of the shifts. *Print the Ritz values and the corresponding Ritz estimates obtained from _neigh. mcaitr > 0: *Print if a restart is needed. mcaitr > 1: *Print the number of Arnoldi vector being generated and the B-norm of the current residual. mcaitr > 2: *Print j-th column of the Hessenberg matrix H. *Print reorthogonalization and iterative refinement information, *Print the final upper Hessenberg matrix of order K+NEV. mcaitr > 3: *Print V^T*B*resid/(B-norm(resid)). mcaitr > 4: *Print current upper Hessenberg matrix. mcaitr > 5: *Print updated Arnoldi vectors and the residual vector. mceigh > 1: *Print the last row of the Schur matrix for H, and the last row of the eigenvector matrix for H. mceigh > 2: *Print the entering upper Hessenberg matrix. *Print the eigenvalues of the current Hessenberg matrix, and associated Ritz estimates. mcgets > 0: *Print the real and imaginary parts of the Ritz values of the Hessenberg matrix and their the corresponding error bounds, KEV, NP. mcapps > 0: *Print information about where deflation occured. mcapps > 1: *Print sigmak, betak, order of the final Hessenberg matrix, and the final compressed upper Hessenberg matrix. mcapps > 2: *Print implicit application of shift number, the shift. *Print the indices of the submatrix that the shift is applied. mcapps > 3: *Print the matrix H before and after the application of each shift, updated residual for next iteration. mcapps > 4: *Print the accumulated unitary Hessenberg matrix Q, and the updated matrix of Arnoldi vectors. mceupd > 0: *Print the number of converged Ritz values, B-norm of the residual, all NCV Ritz values and error bounds. mceupd > 1: *Print the final upper Hessenberg matrix computed by _naupd. *If Ritz vectors are requested, print the eigenvalues and the last row of the Schur vectors as computed by _neupd. mceupd > 2: *If Ritz vectors are requested, print the threshold eigenvalue used for re-ordering. *If Ritz vectors are requested, print the number of eigenvalues to reorder and the number of converged Ritz values. *If Ritz vectors are requested, print the upper quasi-matrix computed by _neupd. *If Ritz vectors are requested, print the Ritz values. *If Ritz vectors are requested, print the last row of the eigenvector matrix. *Print the NCV Ritz estimates in the original system. mceupd > 3: *Print the integer array of pointers. *If Ritz vectors are requested, print the eigenvector matrix. mceupd > 4: *If Ritz vectors are requested, print the Q matrix of the QR factorization of the matrix representing the wanted invariant subspace. *If Ritz vectors are requested, print the Schur vectors. arpack-akloeckner-07/DOCUMENTS/ex-nonsym.doc0000644000175000017500000002241206155405763020474 0ustar andreasandreasc----------------------------------------------------------------------- c c\Example-1 c ... Suppose want to solve A*x = lambda*x in regular mode c ... so OP = A and B = I. c ... Assume "call matvecA(n,x,y)" computes y = A*x c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 1 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, info ) c stop c end c c\Example-2 c ... Suppose want to solve A*x = lambda*x in shift-invert mode c ... so OP = inv[A - sigma*I] and B = I, sigma has zero c ... imaginary part c ... Assume "call solve(n,rhs,x)" solves [A - sigma*I]*x = rhs c ... Assume exact shifts are used c ... c ido = 0 c iaparam(7) = 3 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call solve (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, info ) c stop c end c c\Example-3 c ... Suppose want to solve A*x = lambda*M*x in regular mode c ... so OP = inv[M]*A and B = M. c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call matvecA(n,x,y)" computes y = A*x c ... Assume "call solveM(n,rhs,x)" solves M*x = rhs c ... Assume user will supplied shifts c ... c ido = 0 c iparam(7) = 2 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call matvecA (n, workd(ipntr(1)), temp_array) c call solveM (n, temp_array, workd(ipntr(2))) c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c c ... delete this last conditional if want to use exact shifts c else if (ido .eq. 3) then c ... compute shifts and put in workl starting from the position c ... pointed by ipntr(14). c np = iparam(8) c call scopy (np, shifts, 1, workl(ipntr(14), 1) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, info ) c stop c end c c\Example-4 c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode c ... so OP = inv[A - sigma*M]*M and B = M, sigma has zero c ... imaginary part c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 3 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1) then c call matvecM (n, workd(ipntr(1)), temp_array) c call solve (n, temp_array, workd(ipntr(2))) c go to 10 c else if (ido .eq. 1) then c call solve (n, workd(ipntr(3)), workd(ipntr(2))) c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, info ) c stop c end c c\Example-5 c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode c ... So OP = Real_Part{inv[A-SIGMA*M]*M and B=M, sigma has c ... nonzero imaginary part c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs c ... in complex arithmetic c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 3 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1) then c call matvecM (n, workd(ipntr(1)), temp_array) c call solve(n, temp_array, complex_array) c do i = 1, n c workd(ipntr(2)+i-1) = real(complex_array(i)) c end do c go to 10 c else if (ido .eq. 1) then c call solve (n, workd(ipntr(3)), complex_array) c do i = 1, n c workd(ipntr(2)+i-1) = real(complex_array(i)) c end do c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess. c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, info ) c ... Use Rayleigh quotient to transform d(:,1) and d(:,2) c to the approximation to the original problem. c stop c end c c\Example-6 c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode c ... So OP = Imaginary_Part{inv[A-SIGMA*M]*M and B=M, sigma must c ... have nonzero imaginary part c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs c ... in complex arithmetic c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 3 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1) then c call matvecM (n, workd(ipntr(1)), temp_array) c call solve(n, temp_array, complex_array) c do i = 1, n c workd(ipntr(2)+i-1) = aimag(complex_array(i)) c end do c go to 10 c else if (ido .eq. 1) then c call solve (n, workd(ipntr(3)), complex_array) c do i = 1, n c workd(ipntr(2)+i-1) = aimag(complex_array(i)) c end do c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, info ) c ... Use Rayleigh quotient to transform d(:,1) and d(:,2) c to the Ritz approximation to the original problem. c stop c end c c\EndDoc arpack-akloeckner-07/DOCUMENTS/ex-sym.doc0000644000175000017500000002120506155406267017760 0ustar andreasandreasc----------------------------------------------------------------------- c c\Example-1 c ... Suppose want to solve A*x = lambda*x in regular mode c ... so OP = A and B = I. c ... Assume "call matvecA(n,x,y)" computes y = A*x c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 1 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _saupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... Call _seupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, c & n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c c stop c end c c\Example-2 c ... Suppose want to solve A*x = lambda*x in shift-invert mode c ... so OP = inv[A - sigma*I] and B = I. c ... Assume "call solve(n,rhs,x)" solves [A - sigma*I]*x = rhs c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 3 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _saupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call solve (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... Call _seupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, c & n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c c\Example-3 c ... Suppose want to solve A*x = lambda*M*x in regular mode c ... so OP = inv[M]*A and B = M. c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call matvecA(n,x,y)" computes y = A*x c ... Assume "call solveM(n,rhs,x)" solves M*x = rhs c ... Assume user will supplied shifts c ... c ido = 0 c iparam(7) = 2 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _saupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call matvecA (n, workd(ipntr(1)), temp_array) c call _scopy (n, temp_array, 1, workd(ipntr(1)), 1) c call solveM (n, temp_array, workd(ipntr(2))) c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c c ... delete this last conditional if want to use exact shifts c else if (ido .eq. 3) then c ... compute shifts and put in the first np locations of work c np = iparam(8) c call _copy (np, shifts, 1, workl(ipntr(11), 1) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _seupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, c & n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c stop c end c c\Example-4 c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode c ... so OP = (inv[A - sigma*M])*M and B = M. c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 3 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _saupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1) then c call matvecM (n, workd(ipntr(1)), temp_array) c call solve (n, temp_array, workd(ipntr(2))) c go to 10 c else if (ido .eq. 1) then c call solve (n, workd(ipntr(3)), workd(ipntr(2))) c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _seupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, c & n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c c stop c end c c\Example-5 c ... Suppose want to solve K*x = lambda*KG*x in Buckling mode c ... so OP = (inv[K - sigma*KG])*K and B = K. c ... Assume "call matvecM(n,x,y)" computes y = KG*x c ... Assume "call matvecA(n,x,y)" computes y = K*x c ... Assume "call solve(n,rhs,x)" solves [K - sigma*KG]*x = rhs c ... Assume exact shifts are used c c ido = 0 c iparam(7) = 4 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _saupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1) then c call matvecA (n, workd(ipntr(1)), temp_array) c solve (n, temp_array, workd(ipntr(2))) c go to 10 c else if (ido .eq. 1) then c call solve (n, workd(ipntr(3)), workd(ipntr(2))) c go to 10 c else if (ido .eq. 2) then c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _seupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, c & n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c stop c end c c\Example-6 c ... Suppose want to solve A*x = lambda*M*x in Cayley mode c ... so OP = inv[A - sigma*M]*[A + sigma*M] and B = M. c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call matvecA(n,x,y)" computes y = A*x c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 5 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _saupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c if (ido .eq. -1) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c call matvecA (n, workd(ipntr(1)), temp_array) c call _axpy (n, sigma, workd(inptr(2)), 1, temp_array, 1) c call solve (n, temp_array, workd(ipntr(2))) c go to 10 c else if (ido .eq. 1) then c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) c call _axpy (n, sigma, workd(inptr(3)), 1, workd(ipntr(2)), 1) c call _copy (n, workd(inptr(2)), 1, workd(ipntr(3)), 1) c call solve (n, workd(ipntr(3)), workd(ipntr(2))) c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _seupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _seupd ( rvec, 'All', select, d, z, ldz, sigma, bmat, c & n, which, nev, tol, resid, ncv, v, ldv, iparam, c & ipntr, workd, workl, lworkl, info ) c stop c end c\EndDoc c arpack-akloeckner-07/DOCUMENTS/stat.doc0000644000175000017500000000655206052767374017526 0ustar andreasandreasc----------------------------------------------------------------------- c c Include this file to get timing statistics for the different parts c of the Arnoldi update iteration. An easy way to initialize all the c timing information to zero at the beginning is by: c c call sstats <-- symmetric code c call sstatn <-- nonsymmetric code c call cstatn <-- complex code c c----------------------------------------------------------------------- c c nopx = total number of user OP*x operation c nbx = total number of user B*x operation (same as copy when B = I) c nrorth = total number of reorthogonalization steps taken c nitref = total number of it. refinement steps in reorthogonalization c nrstrt = total number of restart steps c c----------------------------------------------------------------------- c c======================================================== c=== Common to both symmetric and nonsymmetric code === c======================================================== c c tgetv0 = total time spent in generating starting vector and c restarted vector for the Arnoldi sequence. c titref = total time spent in iterative refinement phase in SSAITR. c trvec = total time spent in computing the Ritz vectors before exit. c c==================================== c=== Specific to symmetric code === c==================================== c c tsaupd = total time spent in SSAUPD. c tsaup2 = total time spent in SSAUP2. c tsaitr = total time spent in the basic Arnoldi iteration loop, c including iterative refinement in SSAITR. c tseigt = total time spent in computing the tridiagonal eigenvalue c subproblem at each iteration. c tsgets = total time spent in getting the shifts at each iteration. c tsapps = total time spent in applying the shifts at each iteration. c tsconv = total time spent in convergence test at each iteration. c c======================================= c=== Specific to nonsymmetric code === c======================================= c c tnaupd = total time spent in SNAUPD. c tnaup2 = total time spent in SNAUP2. c tnaitr = total time spent in the basic Arnoldi iteration loop, c including iterative refinement in SNAITR. c tneigh = total time spent in computing the Hessenberg eigenvalue c subproblem at each iteration. c tngets = total time spent in getting the shifts at each iteration. c tnapps = total time spent in applying the shifts at each iteration. c tnconv = total time spent in convergence test at each iteration. c c================================== c=== Specific to complex code === c================================== c c tcaupd = total time spent in CNAUPD. c tcaup2 = total time spent in CNAUP2. c tcaitr = total time spent in the basic Arnoldi iteration loop, c including iterative refinement in CNAITR. c tceigh = total time spent in computing the Hessenberg eigenvalue c subproblem at each iteration. c tcgets = total time spent in getting the shifts at each iteration. c tcapps = total time spent in applying the shifts at each iteration. c tcconv = total time spent in convergence test at each iteration. c c================== c=== User time === c================== c c tmvopx = total time spent in computing Y = OP * X c tmvbx = total time spent in computing Y = B * X c c======================================================================= c arpack-akloeckner-07/DOCUMENTS/README0000644000175000017500000000106706045330115016715 0ustar andreasandreas There are five documents within the DOCUMENT subdirectory. In summary, ex-nonsym.doc, ex-sym.doc and ex-complex.doc ------------- ---------- -------------- Example Templates of how to invoke the different computational modes offered by [D,S]NAUPD, [D,S]SAUPD and [C,Z]NAUPD. stat.doc -------- File that gets timing statistics for the different parts of the Arnoldi update iteration codes within ARPACK. debug.doc --------- File that explains the different printing options of the Arnoldi update iteration codes within ARPACK. arpack-akloeckner-07/DOCUMENTS/ex-complex.doc0000644000175000017500000001307006155406424020613 0ustar andreasandreasc----------------------------------------------------------------------- c c\Example-1 c ... Suppose want to solve A*x = lambda*x in regular mode c ... so OP = A and B = I. c ... Assume "call matvecA(n,x,y)" computes y = A*x c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 1 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, rwork, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call matvecA (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, rwork, info ) c stop c end c c\Example-2 c ... Suppose want to solve A*x = lambda*x in shift-invert mode c ... so OP = inv[A - sigma*I] and B = I c ... Assume "call solve(n,rhs,x)" solves [A - sigma*I]*x = rhs c ... Assume exact shifts are used c ... c ido = 0 c iaparam(7) = 3 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'I', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, rwork, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call solve (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, rwork, info ) c stop c end c c\Example-3 c ... Suppose want to solve A*x = lambda*M*x in regular mode c ... so OP = inv[M]*A and B = M. c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call matvecA(n,x,y)" computes y = A*x c ... Assume "call solveM(n,rhs,x)" solves M*x = rhs c ... Assume user will supplied shifts c ... c ido = 0 c iparam(7) = 2 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, rwork, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c call matvecA (n, workd(ipntr(1)), temp_array) c call solveM (n, temp_array, workd(ipntr(2))) c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c c ... delete this last conditional if want to use exact shifts c else if (ido .eq. 3) then c ... compute shifts and put in workl starting from the position c ... pointed by ipntr(14). c np = iparam(8) c call scopy (np, shifts, 1, workl(ipntr(14), 1) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, rwork, info ) c stop c end c c\Example-4 c ... Suppose want to solve A*x = lambda*M*x in shift-invert mode c ... so OP = inv[A - sigma*M]*M and B = M c ... Assume "call matvecM(n,x,y)" computes y = M*x c ... Assume "call solve(n,rhs,x)" solves [A - sigma*M]*x = rhs c ... Assume exact shifts are used c ... c ido = 0 c iparam(7) = 3 c c %------------------------------------% c | Beginning of reverse communication | c %------------------------------------% c 10 continue c call _naupd ( ido, 'G', n, which, nev, tol, resid, ncv, v, ldv, c & iparam, ipntr, workd, workl, lworkl, rwork, info ) c if (ido .eq. -1) then c call matvecM (n, workd(ipntr(1)), temp_array) c call solve (n, temp_array, workd(ipntr(2))) c go to 10 c else if (ido .eq. 1) then c call solve (n, workd(ipntr(3)), workd(ipntr(2))) c go to 10 c else if (ido .eq. 2) then c call matvecM (n, workd(ipntr(1)), workd(ipntr(2))) c go to 10 c end if c %------------------------------% c | End of Reverse communication | c %------------------------------% c c ... call _neupd to postprocess c ... want the Ritz vectors set rvec = .true. else rvec = .false. c call _neupd ( rvec, 'All', select, d, d(1,2), v, ldv, c & sigmar, sigmai, workev, bmat, n, which, nev, tol, c & resid, ncv, v, ldv, iparam, ipntr, workd, workl, c & lworkl, rwork, info ) c stop c end c\EndDoc arpack-akloeckner-07/EXAMPLES/0000755000175000017500000000000006624631240015714 5ustar andreasandreasarpack-akloeckner-07/EXAMPLES/COMPLEX/0000755000175000017500000000000007173434261017027 5ustar andreasandreasarpack-akloeckner-07/EXAMPLES/COMPLEX/makefile0000644000175000017500000000321406221770644020530 0ustar andreasandreas# # makefile to run simple examples of the reverse communication # protocol. # # Modify if ALIBS library was built somewhere else. # # If ALIBS (defined in ../../ARmake.inc) contains the BLAS and LAPACK # libraries installed on your system, you DO NOT need to change this # makefile. OTHERWISE, you may need to modify the Makefile in the top level # ARPACK directory tree to include cdrv and/or zdrv in the # definition of the PRECISION variable, and issue 'make lib' from there. # For example: # # PRECISION = single double sdrv ddrv # #\SCCS Information: @(#) # FILE: makefile SID: 2.2 DATE OF SID: 9/24/96 RELEASE: 2 # include ../../ARmake.inc # # Issue "complex" to make all 8 complex drivers. # Issue "cndrv" to make 4 single precision complex drivers. # Issue "zndrv" to make 4 double precision complex drivers. # complex: cndrv zndrv #----------------------------------------------------------------------- # Complex problem using single complex # cndrv: cndrv1 cndrv2 cndrv3 cndrv4 cndrv1: cndrv1.o $(FC) $(FFLAGS) cndrv1.o $(ALIBS) -o cndrv1 # cndrv2: cndrv2.o $(FC) $(FFLAGS) cndrv2.o $(ALIBS) -o cndrv2 # cndrv3: cndrv3.o $(FC) $(FFLAGS) cndrv3.o $(ALIBS) -o cndrv3 # cndrv4: cndrv4.o $(FC) $(FFLAGS) cndrv4.o $(ALIBS) -o cndrv4 # #---------------------------------------------------------------------- # Complex problem using double complex # zndrv: zndrv1 zndrv2 zndrv3 zndrv4 zndrv1: zndrv1.o $(FC) $(FFLAGS) zndrv1.o $(ALIBS) -o zndrv1 # zndrv2: zndrv2.o $(FC) $(FFLAGS) zndrv2.o $(ALIBS) -o zndrv2 # zndrv3: zndrv3.o $(FC) $(FFLAGS) zndrv3.o $(ALIBS) -o zndrv3 # zndrv4: zndrv4.o $(FC) $(FFLAGS) zndrv4.o $(ALIBS) -o zndrv4 arpack-akloeckner-07/EXAMPLES/COMPLEX/cndrv1.f0000644000175000017500000003505507173000235020371 0ustar andreasandreas program cndrv1 c c Example program to illustrate the idea of reverse communication c for a standard complex nonsymmetric eigenvalue problem. c c We implement example one of ex-complex.doc in DOCUMENTS directory c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is obtained from the standard central difference c discretization of the convection-diffusion operator c (Laplacian u) + rho*(du / dx) c on the unit squre [0,1]x[0,1] with zero Dirichlet boundary c condition. c c ... OP = A and B = I. c c ... Assume "call av (nx,x,y)" computes y = A*x c c ... Use mode 1 of CNAUPD. c c\BeginLib c c\Routines called c cnaupd ARPACK reverse communication interface routine. c cneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c scnrm2 Level 1 BLAS that computes the norm of a complex vector. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv1.F SID: 2.4 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c--------------------------------------------------------------------------- c c %-----------------------------% c | Define maximum dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=12, maxncv=30, ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Complex & ax(maxn), d(maxncv), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), resid(maxn), & workl(3*maxncv*maxncv+5*maxncv) Real & rwork(maxncv), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nx, nev, ncv, lworkl, info, j, & ierr, nconv, maxitr, ishfts, mode Complex & sigma Real & tol logical rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external scnrm2, caxpy, slapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV, WHICH to solve problems of | c | different sizes, and to get different parts of | c | the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' c c %---------------------------------------------------% c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated to start the ARNOLDI iteration. | c %---------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shift with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of CNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | CNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 1 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine CNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call cnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork,info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform matrix vector multiplication | c | y <--- OP*x | c | The user should supply his/her own | c | matrix vector multiplication routine here | c | that takes workd(ipntr(1)) as the input | c | vector, and return the matrix vector | c | product to workd(ipntr(2)). | c %-------------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call CNAUPD again. | c %-----------------------------------------% c go to 10 end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in CNAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using CNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call cneupd (rvec, 'A', select, d, v, ldv, sigma, & workev, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork, ierr) c c %----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D. The corresponding | c | eigenvectors are returned in the first NCONV | c | (=IPARAM(5)) columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of CNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(nx, v(1,j), ax) call caxpy(n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1),rd(j,2)) 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and relative residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NDRV1' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program cndrv1. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector subroutine c c The matrix used is the convection-diffusion operator c discretized using centered difference. c subroutine av (nx, v, w) integer nx, j, lo Complex & v(nx*nx), w(nx*nx), one, h2 parameter (one = (1.0E+0, 0.0E+0) ) external caxpy, tv c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c derived from the standard central difference discretization c of the convection-diffusion operator (Laplacian u) + rho*(du/dx) c with zero boundary condition. c c The subroutine TV is called to computed y<---T*x. c c h2 = one / cmplx((nx+1)*(nx+1)) c call tv(nx,v(1),w(1)) call caxpy(nx, -one/h2, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call caxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) call caxpy(nx, -one/h2, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call caxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) c return end c========================================================================= subroutine tv (nx, x, y) c integer nx, j Complex & x(nx), y(nx), h, h2, dd, dl, du c Complex & one, rho parameter (one = (1.0E+0, 0.0E+0) , & rho = (1.0E+2, 0.0E+0) ) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal c h = one / cmplx(nx+1) h2 = h*h dd = (4.0E+0, 0.0E+0) / h2 dl = -one/h2 - (5.0E-1, 0.0E+0) *rho/h du = -one/h2 + (5.0E-1, 0.0E+0) *rho/h c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/COMPLEX/cndrv2.f0000644000175000017500000003505107173434221020374 0ustar andreasandreas program cndrv2 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a standard complex nonsymmetric eigenvalue c problem. c c We implement example two of ex-complex.doc in DOCUMENTS directory c c\Example-2 c ... Suppose we want to solve A*x = lambda*x in shift-invert mode, c where A is derived from the central difference discretization c of the 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition. c ... The shift sigma is a complex number. c c ... OP = inv[A-sigma*I] and B = I. c c ... Use mode 3 of CNAUPD. c c\BeginLib c c\Routines called: c cnaupd ARPACK reverse communication interface routine. c cneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c cgttrf LAPACK tridiagonal factorization routine. c cgttrs LAPACK tridiagonal solve routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c ccopy Level 1 BLAS that copies one vector to another. c scnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv2.F SID: 2.6 DATE OF SID: 10/18/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Complex & ax(maxn), d(maxncv), resid(maxn), & v(ldv, maxncv), workd(3*maxn), & workev(2*maxncv), & workl(3*maxncv*maxncv+5*maxncv), & dd(maxn), dl(maxn), du(maxn), & du2(maxn) Real & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode Complex & h, h2, s, sigma, s1, s2, s3, rho common /convct/ rho c Real & tol logical rvec c c %------------% c | Parameters | c %------------% c Complex & one, zero, two parameter (one = (1.0E+0, 0.0E+0) , & zero = (0.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external cgttrf, cgttrs, caxpy, ccopy, scnrm2, & slapy2 c c %-----------------------% c | Executable statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | standard eigenvalue problem is solved (BMAT = | c | 'I'). NEV is the number of eigenvalues (closest | c | to the shift SIGMA) to be approximated. Since | c | the shift-invert mode is used, WHICH is set to | c | 'LM'. The user can modify NEV, NCV, SIGMA to | c | solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigma = zero c c %----------------------------------------------------% c | Construct C = A - SIGMA*I, factor C in complex | c | arithmetic (using LAPACK subroutine cgttrf). The | c | matrix A is chosen to be the tridiagonal matrix | c | derived from standard central difference of the | c | 1-d convection diffusion operator - u``+ rho*u` on | c | the interval [0, 1] with zero Dirichlet boundary | c | condition. | c %----------------------------------------------------% c rho = (1.0E+1, 0.0E+0) h = one / cmplx(n+1) h2 = h*h s = rho / two c s1 = -one/h2 - s/h s2 = two/h2 - sigma s3 = -one/h2 + s/h c do 10 j = 1, n-1 dl(j) = s1 dd(j) = s2 du(j) = s3 10 continue dd(n) = s2 c call cgttrf(n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV2.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in CNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of CNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details see the | c | documentation in CNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine CNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call cnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork,info ) c if (ido .eq. -1 .or. ido .eq. 1 ) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*I]*x | c | The user should supply his/her own linear | c | system solver here that takes | c | workd(ipntr(1)) as the input, and returns | c | the result to workd(ipntr(2)). | c %-------------------------------------------% c call ccopy( n, workd(ipntr(1)),1, workd(ipntr(2)), 1) c call cgttrs('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV2.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call CNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in CNAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ',info print *, ' Check the documentation in _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using CNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call cneupd (rvec, 'A', select, d, v, ldv, sigma, & workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, rwork, ierr) c c %----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D. The corresponding | c | eigenvectors are returned in the first NCONV | c | (=IPARAM(5)) columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of CNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' else c nconv = iparam(5) do 60 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call caxpy(n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1),rd(j,2)) 60 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NDRV2 ' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program cndrv2. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------- c c matrix vector multiplication subroutine c subroutine av (n, v, w) integer n, j Complex & v(n), w(n), rho, two, one, dd, dl, du, s, h, & h2 parameter (one = (1.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) ) common /convct/ rho c h = one / cmplx(n+1) h2 = h*h s = rho / two dd = two / h2 dl = -one/h2 - s/h du = -one/h2 + s/h c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end arpack-akloeckner-07/EXAMPLES/COMPLEX/cndrv3.f0000644000175000017500000003673407173434225020412 0ustar andreasandreas program cndrv3 c c Simple program to illustrate the idea of reverse communication c in inverse mode for a generalized complex nonsymmetric eigenvalue c problem. c c We implement example three of ex-complex.doc in DOCUMENTS directory c c\Example-3 c ... Suppose we want to solve A*x = lambda*B*x in regular mode, c where A and B are derived from the finite element discretization c of the 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition using c piecewise linear elements. c c ... OP = inv[M]*A and B = M. c c ... Use mode 2 of CNAUPD. c c\BeginLib c c\Routines called: c cnaupd ARPACK reverse communication interface routine. c cneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c cgttrf LAPACK tridiagonal factorization routine. c cgttrs LAPACK tridiagonal solve routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c scnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv3.F SID: 2.4 DATE OF SID: 10/18/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Complex & ax(maxn), mx(maxn), d(maxncv), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(2*maxncv), & workl(3*maxncv*maxncv+5*maxncv), & dd(maxn), dl(maxn), du(maxn), du2(maxn) Real & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Complex & sigma, h Real & tol logical rvec c c %------------% c | Parameters | c %------------% c Complex & zero, one parameter (zero = (0.0E+0, 0.0E+0) , & one = (1.0E+0, 0.0E+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external caxpy, ccopy, scnrm2, cgttrf, cgttrs, & slapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues to be | c | approximated. The user can modify NEV, NCV, WHICH | c | to solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = zero c c %-----------------------------------------------------% c | The matrix M is chosen to be the symmetric tri- | c | diagonal matrix with 4 on the diagonal and 1 on the | c | off diagonals. It is factored by LAPACK subroutine | c | cgttrf. | c %-----------------------------------------------------% c h = one / cmplx(n+1) do 20 j = 1, n-1 dl(j) = one*h dd(j) = (4.0E+0, 0.0E+0) *h du(j) = one*h 20 continue dd(n) = (4.0E+0, 0.0E+0) *h c call cgttrf(n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf. ' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in CNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of CNAUPD is used | c | (IPARAM(7) = 2). All these options can be | c | changed by the user. For details, see the | c | documentation in CNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 2 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine CNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call cnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %----------------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c | The user should supply his/her own | c | matrix vector routine and a linear | c | system solver. The matrix-vector | c | subroutine should take workd(ipntr(1)) | c | as input, and the final result should | c | be returned to workd(ipntr(2)). | c %----------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call cgttrs('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs. ' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call CNAUPD again. | c %-----------------------------------------% c go to 10 c else if ( ido .eq. 2) then c c %-------------------------------------% c | Perform y <--- M*x | c | The matrix vector multiplication | c | routine should take workd(ipntr(1)) | c | as input and return the result to | c | workd(ipntr(2)). | c %-------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call CNAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in CNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ',info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using CNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call cneupd ( rvec, 'A', select, d, v, ldv, sigma, & workev, bmat, n, which, nev, tol, resid, ncv, v, & ldv, iparam, ipntr, workd, workl, lworkl, rwork, & ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D. The corresponding | c | eigenvectors are returned in the first NCONV | c | (=IPARAM(5)) columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of CNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd' print *, ' ' c else c nconv = iparam(5) do 80 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*M*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call caxpy(n, -d(j), mx, 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1),rd(j,2)) 80 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and relative residuals') c end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NDRV3 ' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated ', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine av (n, v, w) integer n, j Complex & v(n), w(n), one, two, dd, dl, du, s, h, rho parameter (one = (1.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) , & rho = (1.0E+1, 0.0E+0) ) c c Compute the matrix vector multiplication y<---A*x c where A is the stiffness matrix formed by using piecewise linear c elements on [0,1]. c h = one / cmplx(n+1) s = rho / two dd = two / h dl = -one/h - s du = -one/h + s c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end c------------------------------------------------------------------------ subroutine mv (n, v, w) integer n, j Complex & v(n), w(n), one, four, h parameter (one = (1.0E+0, 0.0E+0) , & four = (4.0E+0, 0.0E+0) ) c c Compute the matrix vector multiplication y<---M*x c where M is the mass matrix formed by using piecewise linear elements c on [0,1]. c w(1) = four*v(1) + one*v(2) do 10 j = 2,n-1 w(j) = one*v(j-1) + four*v(j) + one*v(j+1) 10 continue w(n) = one*v(n-1) + four*v(n) c h = one / cmplx(n+1) call cscal(n, h, w, 1) return end arpack-akloeckner-07/EXAMPLES/COMPLEX/cndrv4.f0000644000175000017500000004204507173434230020377 0ustar andreasandreas program cndrv4 c c Simple program to illustrate the idea of reverse communication c in shift and invert mode for a generalized complex nonsymmetric c eigenvalue problem. c c We implement example four of ex-complex.doc in DOCUMENTS directory c c\Example-4 c ... Suppose we want to solve A*x = lambda*B*x in shift-invert mode, c where A and B are derived from a finite element discretization c of a 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition using c piecewise linear elements. c c ... where the shift sigma is a complex number. c c ... OP = inv[A-SIGMA*M]*M and B = M. c c ... Use mode 3 of CNAUPD. c c\BeginLib c c\Routines called: c cnaupd ARPACK reverse communication interface routine. c cneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c cgttrf LAPACK tridiagonal factorization routine. c cgttrs LAPACK tridiagonal solve routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c ccopy Level 1 BLAS that copies one vector to another. c scnrm2 Level 1 BLAS that computes the norm of a complex vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv4.F SID: 2.4 DATE OF SID: 10/18/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c----------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Complex & ax(maxn), mx(maxn), d(maxncv), & v(ldv,maxncv), workd(3*maxn), resid(maxn), & workev(2*maxncv), & workl(3*maxncv*maxncv+5*maxncv), & dd(maxn), dl(maxn), du(maxn), & du2(maxn) Real & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode Complex & rho, h, s, & sigma, s1, s2, s3 common /convct/ rho c Real & tol logical rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external scnrm2, caxpy, ccopy, cgttrf, cgttrs, & slapy2 c c %------------% c | Parameters | c %------------% c Complex & one, zero, two, four, six parameter (one = (1.0E+0, 0.0E+0) , & zero = (0.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) , & four = (4.0E+0, 0.0E+0) , & six = (6.0E+0, 0.0E+0) ) c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues (closest | c | to SIGMAR) to be approximated. Since the | c | shift-invert mode is used, WHICH is set to 'LM'. | c | The user can modify NEV, NCV, SIGMA to solve | c | problems of different sizes, and to get different | c | parts of the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = one c c %--------------------------------------------------% c | Construct C = A - SIGMA*M in COMPLEX arithmetic. | c | Factor C in COMPLEX arithmetic (using LAPACK | c | subroutine cgttrf). The matrix A is chosen to be | c | the tridiagonal matrix derived from the standard | c | central difference discretization of the 1-d | c | convection-diffusion operator u``+ rho*u` on the | c | interval [0, 1] with zero Dirichlet boundary | c | condition. The matrix M is chosen to be the | c | symmetric tridiagonal matrix with 4.0 on the | c | diagonal and 1.0 on the off-diagonals. | c %--------------------------------------------------% c rho = (1.0E+1, 0.0E+0) h = one / cmplx(n+1) s = rho / two c s1 = -one/h - s - sigma*h/six s2 = two/h - four*sigma*h/six s3 = -one/h + s - sigma*h/six c do 10 j = 1, n-1 dl(j) = s1 dd(j) = s2 du(j) = s3 10 continue dd(n) = s2 c call cgttrf(n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in CNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of CNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details see the | c | documentation in CNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------% c | M A I N L O O P(Reverse communication) | c %------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine CNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call cnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork, info ) c if (ido .eq. -1) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*M]*M*x | c | to force starting vector into the range | c | of OP. The user should supply his/her | c | own matrix vector multiplication routine | c | and a linear system solver. The matrix | c | vector multiplication routine should take | c | workd(ipntr(1)) as the input. The final | c | result should be returned to | c | workd(ipntr(2)). | c %-------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) call cgttrs('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call CNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 1) then c c %-----------------------------------------% c | Perform y <-- OP*x = inv[A-sigma*M]*M*x | c | M*x has been saved in workd(ipntr(3)). | c | The user only need the linear system | c | solver here that takes workd(ipntr(3)) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call ccopy( n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call cgttrs ('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call CNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- M*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call CNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %----------------------------% c | Error message, check the | c | documentation in CNAUPD | c %----------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using CNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call cneupd (rvec, 'A', select, d, v, ldv, sigma, & workev, bmat, n, which, nev, tol, resid, ncv, v, & ldv, iparam, ipntr, workd, workl, lworkl, rwork, & ierr) c c %----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D. The corresponding | c | eigenvectors are returned in the first NCONV | c | (=IPARAM(5)) columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of CNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c nconv = iparam(5) do 80 j=1, nconv c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call caxpy(n, -d(j), mx, 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1),rd(j,2)) 80 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and direct residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NDRV4 ' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine mv (n, v, w) integer n, j Complex & v(n), w(n), one, four, six, h parameter (one = (1.0E+0, 0.0E+0) , & four = (4.0E+0, 0.0E+0) , & six = (6.0E+0, 0.0E+0) ) c c Compute the matrix vector multiplication y<---M*x c where M is a n by n symmetric tridiagonal matrix with 4 on the c diagonal, 1 on the subdiagonal and superdiagonal. c w(1) = ( four*v(1) + one*v(2) ) / six do 40 j = 2,n-1 w(j) = ( one*v(j-1) + four*v(j) + one*v(j+1) ) / six 40 continue w(n) = ( one*v(n-1) + four*v(n) ) / six c h = one / cmplx(n+1) call cscal(n, h, w, 1) return end c------------------------------------------------------------------ subroutine av (n, v, w) integer n, j Complex & v(n), w(n), one, two, dd, dl, du, s, h, rho parameter (one = (1.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) ) common /convct/ rho c h = one / cmplx(n+1) s = rho / two dd = two / h dl = -one/h - s du = -one/h + s c w(1) = dd*v(1) + du*v(2) do 40 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 40 continue w(n) = dl*v(n-1) + dd*v(n) return end arpack-akloeckner-07/EXAMPLES/COMPLEX/zndrv1.f0000644000175000017500000003520507173000235020415 0ustar andreasandreas program zndrv1 c c Example program to illustrate the idea of reverse communication c for a standard complex nonsymmetric eigenvalue problem. c c We implement example one of ex-complex.doc in DOCUMENTS directory c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is obtained from the standard central difference c discretization of the convection-diffusion operator c (Laplacian u) + rho*(du / dx) c on the unit squre [0,1]x[0,1] with zero Dirichlet boundary c condition. c c ... OP = A and B = I. c c ... Assume "call av (nx,x,y)" computes y = A*x c c ... Use mode 1 of ZNAUPD . c c\BeginLib c c\Routines called c znaupd ARPACK reverse communication interface routine. c zneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dznrm2 Level 1 BLAS that computes the norm of a complex vector. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv1.F SID: 2.4 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c--------------------------------------------------------------------------- c c %-----------------------------% c | Define maximum dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=12, maxncv=30, ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Complex*16 & ax(maxn), d(maxncv), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), resid(maxn), & workl(3*maxncv*maxncv+5*maxncv) Double precision & rwork(maxncv), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nx, nev, ncv, lworkl, info, j, & ierr, nconv, maxitr, ishfts, mode Complex*16 & sigma Double precision & tol logical rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external dznrm2 , zaxpy , dlapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV, WHICH to solve problems of | c | different sizes, and to get different parts of | c | the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' c c %---------------------------------------------------% c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated to start the ARNOLDI iteration. | c %---------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shift with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of ZNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | ZNAUPD . | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 1 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine ZNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call znaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork,info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform matrix vector multiplication | c | y <--- OP*x | c | The user should supply his/her own | c | matrix vector multiplication routine here | c | that takes workd(ipntr(1)) as the input | c | vector, and return the matrix vector | c | product to workd(ipntr(2)). | c %-------------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call ZNAUPD again. | c %-----------------------------------------% c go to 10 end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in ZNAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using ZNEUPD . | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call zneupd (rvec, 'A', select, d, v, ldv, sigma, & workev, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork, ierr) c c %----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D. The corresponding | c | eigenvectors are returned in the first NCONV | c | (=IPARAM(5)) columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of ZNEUPD . | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(nx, v(1,j), ax) call zaxpy (n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1),rd(j,2)) 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and relative residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NDRV1' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program zndrv1 . | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector subroutine c c The matrix used is the convection-diffusion operator c discretized using centered difference. c subroutine av (nx, v, w) integer nx, j, lo Complex*16 & v(nx*nx), w(nx*nx), one, h2 parameter (one = (1.0D+0, 0.0D+0) ) external zaxpy , tv c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c derived from the standard central difference discretization c of the convection-diffusion operator (Laplacian u) + rho*(du/dx) c with zero boundary condition. c c The subroutine TV is called to computed y<---T*x. c c h2 = one / dcmplx ((nx+1)*(nx+1)) c call tv(nx,v(1),w(1)) call zaxpy (nx, -one/h2, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call zaxpy (nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) call zaxpy (nx, -one/h2, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call zaxpy (nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) c return end c========================================================================= subroutine tv (nx, x, y) c integer nx, j Complex*16 & x(nx), y(nx), h, h2, dd, dl, du c Complex*16 & one, rho parameter (one = (1.0D+0, 0.0D+0) , & rho = (1.0D+2, 0.0D+0) ) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal c h = one / dcmplx (nx+1) h2 = h*h dd = (4.0D+0, 0.0D+0) / h2 dl = -one/h2 - (5.0D-1, 0.0D+0) *rho/h du = -one/h2 + (5.0D-1, 0.0D+0) *rho/h c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/COMPLEX/zndrv2.f0000644000175000017500000003520407173434221020423 0ustar andreasandreas program zndrv2 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a standard complex nonsymmetric eigenvalue c problem. c c We implement example two of ex-complex.doc in DOCUMENTS directory c c\Example-2 c ... Suppose we want to solve A*x = lambda*x in shift-invert mode, c where A is derived from the central difference discretization c of the 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition. c ... The shift sigma is a complex number. c c ... OP = inv[A-sigma*I] and B = I. c c ... Use mode 3 of ZNAUPD . c c\BeginLib c c\Routines called: c znaupd ARPACK reverse communication interface routine. c zneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c zgttrf LAPACK tridiagonal factorization routine. c zgttrs LAPACK tridiagonal solve routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c zcopy Level 1 BLAS that copies one vector to another. c dznrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv2.F SID: 2.6 DATE OF SID: 10/18/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Complex*16 & ax(maxn), d(maxncv), resid(maxn), & v(ldv, maxncv), workd(3*maxn), & workev(2*maxncv), & workl(3*maxncv*maxncv+5*maxncv), & dd(maxn), dl(maxn), du(maxn), & du2(maxn) Double precision & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode Complex*16 & h, h2, s, sigma, s1, s2, s3, rho common /convct/ rho c Double precision & tol logical rvec c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero, two parameter (one = (1.0D+0, 0.0D+0) , & zero = (0.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external zgttrf , zgttrs , zaxpy , zcopy , dznrm2 , & dlapy2 c c %-----------------------% c | Executable statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | standard eigenvalue problem is solved (BMAT = | c | 'I'). NEV is the number of eigenvalues (closest | c | to the shift SIGMA) to be approximated. Since | c | the shift-invert mode is used, WHICH is set to | c | 'LM'. The user can modify NEV, NCV, SIGMA to | c | solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigma = zero c c %----------------------------------------------------% c | Construct C = A - SIGMA*I, factor C in complex | c | arithmetic (using LAPACK subroutine zgttrf ). The | c | matrix A is chosen to be the tridiagonal matrix | c | derived from standard central difference of the | c | 1-d convection diffusion operator - u``+ rho*u` on | c | the interval [0, 1] with zero Dirichlet boundary | c | condition. | c %----------------------------------------------------% c rho = (1.0D+1, 0.0D+0) h = one / dcmplx (n+1) h2 = h*h s = rho / two c s1 = -one/h2 - s/h s2 = two/h2 - sigma s3 = -one/h2 + s/h c do 10 j = 1, n-1 dl(j) = s1 dd(j) = s2 du(j) = s3 10 continue dd(n) = s2 c call zgttrf (n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV2.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in ZNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of ZNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details see the | c | documentation in ZNAUPD . | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine ZNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call znaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork,info ) c if (ido .eq. -1 .or. ido .eq. 1 ) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*I]*x | c | The user should supply his/her own linear | c | system solver here that takes | c | workd(ipntr(1)) as the input, and returns | c | the result to workd(ipntr(2)). | c %-------------------------------------------% c call zcopy ( n, workd(ipntr(1)),1, workd(ipntr(2)), 1) c call zgttrs ('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV2.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call ZNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in ZNAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ',info print *, ' Check the documentation in _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using ZNEUPD . | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call zneupd (rvec, 'A', select, d, v, ldv, sigma, & workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, rwork, ierr) c c %----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D. The corresponding | c | eigenvectors are returned in the first NCONV | c | (=IPARAM(5)) columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of ZNEUPD . | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' else c nconv = iparam(5) do 60 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call zaxpy (n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1),rd(j,2)) 60 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NDRV2 ' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program zndrv2 . | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------- c c matrix vector multiplication subroutine c subroutine av (n, v, w) integer n, j Complex*16 & v(n), w(n), rho, two, one, dd, dl, du, s, h, & h2 parameter (one = (1.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) ) common /convct/ rho c h = one / dcmplx (n+1) h2 = h*h s = rho / two dd = two / h2 dl = -one/h2 - s/h du = -one/h2 + s/h c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end arpack-akloeckner-07/EXAMPLES/COMPLEX/zndrv3.f0000644000175000017500000003707307173434225020436 0ustar andreasandreas program zndrv3 c c Simple program to illustrate the idea of reverse communication c in inverse mode for a generalized complex nonsymmetric eigenvalue c problem. c c We implement example three of ex-complex.doc in DOCUMENTS directory c c\Example-3 c ... Suppose we want to solve A*x = lambda*B*x in regular mode, c where A and B are derived from the finite element discretization c of the 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition using c piecewise linear elements. c c ... OP = inv[M]*A and B = M. c c ... Use mode 2 of ZNAUPD . c c\BeginLib c c\Routines called: c znaupd ARPACK reverse communication interface routine. c zneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c zgttrf LAPACK tridiagonal factorization routine. c zgttrs LAPACK tridiagonal solve routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c dznrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv3.F SID: 2.4 DATE OF SID: 10/18/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Complex*16 & ax(maxn), mx(maxn), d(maxncv), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(2*maxncv), & workl(3*maxncv*maxncv+5*maxncv), & dd(maxn), dl(maxn), du(maxn), du2(maxn) Double precision & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Complex*16 & sigma, h Double precision & tol logical rvec c c %------------% c | Parameters | c %------------% c Complex*16 & zero, one parameter (zero = (0.0D+0, 0.0D+0) , & one = (1.0D+0, 0.0D+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external zaxpy , zcopy , dznrm2 , zgttrf , zgttrs , & dlapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues to be | c | approximated. The user can modify NEV, NCV, WHICH | c | to solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = zero c c %-----------------------------------------------------% c | The matrix M is chosen to be the symmetric tri- | c | diagonal matrix with 4 on the diagonal and 1 on the | c | off diagonals. It is factored by LAPACK subroutine | c | zgttrf . | c %-----------------------------------------------------% c h = one / dcmplx (n+1) do 20 j = 1, n-1 dl(j) = one*h dd(j) = (4.0D+0, 0.0D+0) *h du(j) = one*h 20 continue dd(n) = (4.0D+0, 0.0D+0) *h c call zgttrf (n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf. ' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in ZNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of ZNAUPD is used | c | (IPARAM(7) = 2). All these options can be | c | changed by the user. For details, see the | c | documentation in ZNAUPD . | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 2 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine ZNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call znaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %----------------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c | The user should supply his/her own | c | matrix vector routine and a linear | c | system solver. The matrix-vector | c | subroutine should take workd(ipntr(1)) | c | as input, and the final result should | c | be returned to workd(ipntr(2)). | c %----------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call zgttrs ('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs. ' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call ZNAUPD again. | c %-----------------------------------------% c go to 10 c else if ( ido .eq. 2) then c c %-------------------------------------% c | Perform y <--- M*x | c | The matrix vector multiplication | c | routine should take workd(ipntr(1)) | c | as input and return the result to | c | workd(ipntr(2)). | c %-------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call ZNAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in ZNAUPD . | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ',info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using ZNEUPD . | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call zneupd ( rvec, 'A', select, d, v, ldv, sigma, & workev, bmat, n, which, nev, tol, resid, ncv, v, & ldv, iparam, ipntr, workd, workl, lworkl, rwork, & ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D. The corresponding | c | eigenvectors are returned in the first NCONV | c | (=IPARAM(5)) columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of ZNEUPD . | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd' print *, ' ' c else c nconv = iparam(5) do 80 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*M*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call zaxpy (n, -d(j), mx, 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1),rd(j,2)) 80 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and relative residuals') c end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NDRV3 ' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated ', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine av (n, v, w) integer n, j Complex*16 & v(n), w(n), one, two, dd, dl, du, s, h, rho parameter (one = (1.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) , & rho = (1.0D+1, 0.0D+0) ) c c Compute the matrix vector multiplication y<---A*x c where A is the stiffness matrix formed by using piecewise linear c elements on [0,1]. c h = one / dcmplx (n+1) s = rho / two dd = two / h dl = -one/h - s du = -one/h + s c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end c------------------------------------------------------------------------ subroutine mv (n, v, w) integer n, j Complex*16 & v(n), w(n), one, four, h parameter (one = (1.0D+0, 0.0D+0) , & four = (4.0D+0, 0.0D+0) ) c c Compute the matrix vector multiplication y<---M*x c where M is the mass matrix formed by using piecewise linear elements c on [0,1]. c w(1) = four*v(1) + one*v(2) do 10 j = 2,n-1 w(j) = one*v(j-1) + four*v(j) + one*v(j+1) 10 continue w(n) = one*v(n-1) + four*v(n) c h = one / dcmplx (n+1) call zscal (n, h, w, 1) return end arpack-akloeckner-07/EXAMPLES/COMPLEX/zndrv4.f0000644000175000017500000004221007173434230020420 0ustar andreasandreas program zndrv4 c c Simple program to illustrate the idea of reverse communication c in shift and invert mode for a generalized complex nonsymmetric c eigenvalue problem. c c We implement example four of ex-complex.doc in DOCUMENTS directory c c\Example-4 c ... Suppose we want to solve A*x = lambda*B*x in shift-invert mode, c where A and B are derived from a finite element discretization c of a 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition using c piecewise linear elements. c c ... where the shift sigma is a complex number. c c ... OP = inv[A-SIGMA*M]*M and B = M. c c ... Use mode 3 of ZNAUPD . c c\BeginLib c c\Routines called: c znaupd ARPACK reverse communication interface routine. c zneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c zgttrf LAPACK tridiagonal factorization routine. c zgttrs LAPACK tridiagonal solve routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c zcopy Level 1 BLAS that copies one vector to another. c dznrm2 Level 1 BLAS that computes the norm of a complex vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv4.F SID: 2.4 DATE OF SID: 10/18/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c----------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Complex*16 & ax(maxn), mx(maxn), d(maxncv), & v(ldv,maxncv), workd(3*maxn), resid(maxn), & workev(2*maxncv), & workl(3*maxncv*maxncv+5*maxncv), & dd(maxn), dl(maxn), du(maxn), & du2(maxn) Double precision & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode Complex*16 & rho, h, s, & sigma, s1, s2, s3 common /convct/ rho c Double precision & tol logical rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external dznrm2 , zaxpy , zcopy , zgttrf , zgttrs , & dlapy2 c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero, two, four, six parameter (one = (1.0D+0, 0.0D+0) , & zero = (0.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) , & four = (4.0D+0, 0.0D+0) , & six = (6.0D+0, 0.0D+0) ) c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues (closest | c | to SIGMAR) to be approximated. Since the | c | shift-invert mode is used, WHICH is set to 'LM'. | c | The user can modify NEV, NCV, SIGMA to solve | c | problems of different sizes, and to get different | c | parts of the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = one c c %--------------------------------------------------% c | Construct C = A - SIGMA*M in COMPLEX arithmetic. | c | Factor C in COMPLEX arithmetic (using LAPACK | c | subroutine zgttrf ). The matrix A is chosen to be | c | the tridiagonal matrix derived from the standard | c | central difference discretization of the 1-d | c | convection-diffusion operator u``+ rho*u` on the | c | interval [0, 1] with zero Dirichlet boundary | c | condition. The matrix M is chosen to be the | c | symmetric tridiagonal matrix with 4.0 on the | c | diagonal and 1.0 on the off-diagonals. | c %--------------------------------------------------% c rho = (1.0D+1, 0.0D+0) h = one / dcmplx (n+1) s = rho / two c s1 = -one/h - s - sigma*h/six s2 = two/h - four*sigma*h/six s3 = -one/h + s - sigma*h/six c do 10 j = 1, n-1 dl(j) = s1 dd(j) = s2 du(j) = s3 10 continue dd(n) = s2 c call zgttrf (n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in ZNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of ZNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details see the | c | documentation in ZNAUPD . | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------% c | M A I N L O O P(Reverse communication) | c %------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine ZNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call znaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork, info ) c if (ido .eq. -1) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*M]*M*x | c | to force starting vector into the range | c | of OP. The user should supply his/her | c | own matrix vector multiplication routine | c | and a linear system solver. The matrix | c | vector multiplication routine should take | c | workd(ipntr(1)) as the input. The final | c | result should be returned to | c | workd(ipntr(2)). | c %-------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) call zgttrs ('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call ZNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 1) then c c %-----------------------------------------% c | Perform y <-- OP*x = inv[A-sigma*M]*M*x | c | M*x has been saved in workd(ipntr(3)). | c | The user only need the linear system | c | solver here that takes workd(ipntr(3)) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call zcopy ( n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call zgttrs ('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call ZNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- M*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call ZNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %----------------------------% c | Error message, check the | c | documentation in ZNAUPD | c %----------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using ZNEUPD . | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call zneupd (rvec, 'A', select, d, v, ldv, sigma, & workev, bmat, n, which, nev, tol, resid, ncv, v, & ldv, iparam, ipntr, workd, workl, lworkl, rwork, & ierr) c c %----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D. The corresponding | c | eigenvectors are returned in the first NCONV | c | (=IPARAM(5)) columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of ZNEUPD . | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c nconv = iparam(5) do 80 j=1, nconv c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call zaxpy (n, -d(j), mx, 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1),rd(j,2)) 80 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and direct residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NDRV4 ' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine mv (n, v, w) integer n, j Complex*16 & v(n), w(n), one, four, six, h parameter (one = (1.0D+0, 0.0D+0) , & four = (4.0D+0, 0.0D+0) , & six = (6.0D+0, 0.0D+0) ) c c Compute the matrix vector multiplication y<---M*x c where M is a n by n symmetric tridiagonal matrix with 4 on the c diagonal, 1 on the subdiagonal and superdiagonal. c w(1) = ( four*v(1) + one*v(2) ) / six do 40 j = 2,n-1 w(j) = ( one*v(j-1) + four*v(j) + one*v(j+1) ) / six 40 continue w(n) = ( one*v(n-1) + four*v(n) ) / six c h = one / dcmplx (n+1) call zscal (n, h, w, 1) return end c------------------------------------------------------------------ subroutine av (n, v, w) integer n, j Complex*16 & v(n), w(n), one, two, dd, dl, du, s, h, rho parameter (one = (1.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) ) common /convct/ rho c h = one / dcmplx (n+1) s = rho / two dd = two / h dl = -one/h - s du = -one/h + s c w(1) = dd*v(1) + du*v(2) do 40 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 40 continue w(n) = dl*v(n-1) + dd*v(n) return end arpack-akloeckner-07/EXAMPLES/COMPLEX/README0000644000175000017500000000271206053471324017706 0ustar andreasandreas1. Purpose ------- This directory contains example drivers that call ARPACK subroutines [c,z]naupd.f and [c,z]neupd.f to solve COMPLEX eigenvalue problems using regular, inverse or shift-invert modes. These drivers illustrate how to set various ARPACK parameters to solve different problems in different modes. They provide a guideline on how to use ARPACK's reverse communication interface. The user may modify any one of these drivers, and provide his/her own matrix vector multiplication routine to solve the problem of his/her own interest. 2. Naming convention ----------------- The name for each driver has the form 'XndrvN.f', where X - is 'c' (single precision complex) or 'z' (double precision complex) N - is a number between 1 and 4. If N = 1, the driver solves a STANDARD eigenvalue problem in REGULAR mode N = 2, the driver solves a STANDARD eigenvalue problem in SHIFT-INVERT mode. N = 3, the driver solves a GENERALIZED eigenvalue problem in INVERSE mode N = 4, the driver solves a GENERALIZED eigenvalue problem in SHIFT-INVERT mode. For shift-invert modes (N=2,4), the user needs to provide a complex linear system solver to perform y=inv[A-sigma*B]*x. 3. Usage ----- To run these drivers, you may use the makefile in this directory and issue, for example, "make cndrv1". Then execute using "cndrv1". arpack-akloeckner-07/EXAMPLES/BAND/0000755000175000017500000000000007526641262016427 5ustar andreasandreasarpack-akloeckner-07/EXAMPLES/BAND/dnbdr1.f0000644000175000017500000002746707174073767020000 0ustar andreasandreas program dnbdr1 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-d convection-diffusion operator c c -Laplacian(u) + rho*partial(u)/partial(x). c c on the unit square with zero Dirichlet boundary condition c using standard central difference. c c ... Call DNBAND to find eigenvalues LAMBDA such that c A*x = LAMBDA*x. c c ... Use mode 1 of DNAUPD . c c\BeginLib c c dnband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr1.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn) Complex*16 & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, isub, isup, idiag, mode, maxitr, & nconv logical rvec, first Double precision & tol, rho, h, h2, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two parameter (one = 1.0D+0 , zero = 0.0D+0 , & two = 2.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , dgbmv , daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV, WHICH to solve problems of | c | different sizes, and to get different parts the | c | spectrum. However, The following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'SM' c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of DNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details, see the documentation | c | in DNBAND . | c %---------------------------------------------------% c maxitr = 300 mode = 1 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h = one / dble (nx+1) h2 = h*h c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0D+0 / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c rho = 1.0D+2 isup = kl+ku isub = kl+ku+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one/h2 + rho/two/h a(isub,j) = -one/h2 - rho/two/h 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call dnband (rvec, 'A', select, d, d(1,2), v, ldv, sigmar, sigmai, & workev, n, a, m, lda, rfac, cfac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, workd, & workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR1 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j), 1, ax, 1) call daxpy (n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call daxpy (n, -d(j,2), v(1,j), 1, ax, 1) call daxpy (n, -d(j,1), v(1,j+1), 1, ax, 1) d(j,3) = dlapy2 ( d(j,3), dnrm2 (n, ax, 1) ) d(j,3) = d(j,3) / dlapy2 (d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call dmout (6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DNBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dnbdr2.f0000644000175000017500000003003207174073767017757 0ustar andreasandreas program dnbdr2 c c ... Construct matrices A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-d convection-diffusion operator c c -Laplacian(u) + rho*partial(u)/partial(x). c c on the unit square with zero Dirichlet boundary condition c using standard central difference. c c ... Define the shift SIGMA = (SIGMAR, SIGMAI). c c ... Call DNBAND to find eigenvalues LAMBDA closest to SIGMA c such that c A*x = LAMBDA*x. c c ... Use mode 3 of DNAUPD . c c\BeginLib c c\Routines called: c dnband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr2.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c--------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn) Complex*16 & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, idiag, isub, isup, mode, maxitr, & nconv logical rvec, first Double precision & tol, rho, h2, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two parameter (one = 1.0D+0 , zero = 0.0D+0 , & two = 2.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , daxpy , dgbmv c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues (closest to (SIGMAR,SIGMAI)) to be | c | approximated. Since the shift-invert moded is | c | used, WHICH is set to 'LM'. The user can modify | c | NX, NEV, NCV, SIGMAR, SIGMAI to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, The following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigmar = 1.0D+4 sigmai = 0.0D+0 c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of DNAUPD is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in DNBAND . | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h = one / dble (nx+1) h2 = h*h c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0D+0 / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = 1.0D+1 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isub,j+1) = -one/h2 + rho/two/h a(isup,j) = -one/h2 - rho/two/h 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call dnband (rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, a, m, lda, rfac, cfac, kl, ku, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR2 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j), 1, ax, 1) call daxpy (n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j+1), 1, ax, 1) call daxpy (n, -d(j,2), v(1,j), 1, ax, 1) d(j,3) = dlapy2 ( d(j,3), dnrm2 (n, ax, 1) ) d(j,3) = d(j,3) / dlapy2 (d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call dmout (6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DNBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dnbdr3.f0000644000175000017500000002773707174073767020002 0ustar andreasandreas program dnbdr3 c c ... Construct matrices A and M in LAPACK-style band form. c The matrix A and M are derived from the finite element c discretization of the 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition, c ... Call DNBAND to find eigenvalues LAMBDA such that c A*x = LAMBDA*M*x. c c ... Eigenvalues with largest real parts are sought. c c ... Use mode 2 of DNAUPD . c c\BeginLib c c\Routines called: c dnband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr3.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c------------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn), mx(maxn) Complex*16 & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, idiag, isup, isub, mode, maxitr, & nconv logical rvec, first Double precision & tol, rho, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two parameter (one = 1.0D+0 , zero = 0.0D+0 , & two = 2.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , dgbmv , daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. The user can modify N, NEV, | c | NCV and WHICH to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' c c %----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL has to be set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine machine | c | precision is used. The number IDO is used for | c | reverse communication and has to be set to 0 at | c | the beginning. Setting INFO=0 indicates that we | c | using a randomly generated vector to start the | c | the ARNOLDI process. | c %----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv info = 0 tol = zero ido = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of DNAUPD is used | c | (IPARAM(7) = 2). All these options can be changed | c | by the user. For details, see the documentation | c | in DNBAND . | c %---------------------------------------------------% c mode = 2 maxitr = 300 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / dble (n+1) c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 2.0D+0 / h m(idiag,j) = 4.0D+0 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = 1.0D+1 do 50 j = 1, n a(isup,j+1) = -one/h + rho/two a(isub,j) = -one/h - rho/two m(isup,j+1) = one*h m(isub,j) = one*h 50 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call dnband ( rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, A, M, lda, rfac, cfac, kl, ku, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR3 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call daxpy (n, d(j,2), mx, 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,2), mx, 1, ax, 1) d(j,3) = dlapy2 ( d(j,3), dnrm2 (n, ax, 1) ) d(j,3) = d(j,3) / dlapy2 (d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call dmout (6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DNBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dnbdr4.f0000644000175000017500000002772707172771750017775 0ustar andreasandreas program dnbdr4 c c ... Construct matrices A and M in LAPACK-style band form. c The matrix A and M are derived from the finite element c discretization of the 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition. c c ... Define the shift SIGMA = (SIGMAR, SIGMAI). c c ... Call DNBAND to find eigenvalues LAMBDA closest to SIGMA c such that c A*x = LAMBDA*M*x. c c ... Use mode 3 of DNAUPD. c c\BeginLib c c\Routines called: c dnband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr4.F SID: 2.6 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn), mx(maxn) Complex*16 & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, idiag, isup, isub, mode, maxitr, & nconv logical rvec, first Double precision & tol, rho, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two, six parameter (one = 1.0D+0, zero = 0.0D+0, & two = 2.0D+0, six = 6.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2, dnrm2 external dlapy2, dnrm2, dgbmv, daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. The user can modify N, NEV, | c | NCV and WHICH to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = 1.0D+1 sigmai = 0.0D+0 c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv info = 0 tol = zero ido = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of dnaupd is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in dnaupd. | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = n iparam(7) = 3 c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset('A', lda, n, zero, zero, a, lda) call dlaset('A', lda, n, zero, zero, m, lda) call dlaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / dble(n+1) idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 2.0D+0 / h m(idiag,j) = 4.0D+0 * h / six 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = 1.0D+1 do 40 j = 1, n-1 a(isup,j+1) = -one/h + rho/two a(isub,j) = -one/h - rho/two m(isup,j+1) = one*h/six m(isub,j) = one*h/six 40 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call dnband(rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, A, M, lda, rfac, cfac, kl, ku, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR4 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 50 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy(n, -d(j,1), mx, 1, ax, 1) call dgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call daxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) call dgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call dgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call daxpy(n, -d(j,1), mx, 1, ax, 1) call dgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 50 continue call dmout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relatve residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DNBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dnbdr5.f0000644000175000017500000002776707174073770020001 0ustar andreasandreas program dnbdr5 c c ... Construct matrices A and M in LAPACK-style band form. c The matrix A is a block tridiagonal matrix. Each c diagonal block is a tridiagonal matrix with c 4 on the diagonal, 1-rho*h/2 on the subdiagonal and c 1+rho*h/2 on the superdiagonal. Each off-diagonal block c of A is an identity matrices. c c ... Define COMPLEX shift SIGMA = (SIGMAR,SIGMAI), SIGMAI .ne. 0. c c ... Call DNBAND to find eigenvalues LAMBDA closest to SIGMA c such that c A*x = LAMBDA*x. c c ... Use mode 4 of DNAUPD . c c\BeginLib c c\Routines called: c dnband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr5.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c------------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn) Complex*16 & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, idiag, isup, isub, mode, maxitr, & nconv logical rvec, first Double precision & tol, rho, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two parameter (one = 1.0D+0 , zero = 0.0D+0 , & two = 2.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , dgbmv , daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number NX is the size of each block diagonal | c | of A. The number N(=NX*NX) is the dimension of | c | the matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues (closest to (SIGMAR,SIGMAI)) to be | c | approximated. Since the shift-invert moded is | c | used, WHICH is set to 'LM'. The user can modify | c | NX, NEV, NCV, SIGMAR, SIGMAI to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, The following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR5: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR5: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR5: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigmar = 4.0D-1 sigmai = 6.0D-1 c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 4 of DNAUPD is used | c | (IPARAM(7) = 4). All these options can be changed | c | by the user. For details, see the documentation | c | in DNBAND . | c %---------------------------------------------------% c maxitr = 300 mode = 4 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0D+0 m(idiag,j) = 4.0D+0 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+kl+2 h = one / dble (nx+1) rho = 1.0D+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one+h*rho/two a(isub,j) = -one-h*rho/two 40 continue 50 continue c do 60 j = 1, n-1 m(isup,j+1) = one m(isub,j) = one 60 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one a(isub,j) = -one 70 continue 80 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call dnband (rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, a, m, lda, rfac, cfac, ku, kl, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR5 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j), 1, ax, 1) call daxpy (n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j+1), 1, ax, 1) call daxpy (n, -d(j,2), v(1,j), 1, ax, 1) d(j,3) = dlapy2 ( d(j,3), dnrm2 (n, ax, 1) ) d(j,3) = d(j,3) / dlapy2 (d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call dmout (6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DNBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dnbdr6.f0000644000175000017500000003163207174073771017765 0ustar andreasandreas program dnbdr6 c c ... Construct matrices A and M in LAPACK-style band form. c The matrix A is a block tridiagonal matrix. Each c diagonal block is a tridiagonal matrix with c 4 on the diagonal, 1-rho*h/2 on the subdiagonal and c 1+rho*h/2 on the superdiagonal. Each subdiagonal block c of A is an identity matrix. The matrix M is the c tridiagonal matrix with 4 on the diagonal and 1 on the c subdiagonal and superdiagonal. c c ... Define COMPLEX shift SIGMA=(SIGMAR,SIGMAI), SIGMAI .ne. zero. c c ... Call dnband to find eigenvalues LAMBDA closest to SIGMA c such that c A*x = LAMBDA*M*x. c c ... Use mode 4 of DNAUPD . c c\BeginLib c c\Routines called: c dnband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr6.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c--------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn), mx(maxn) Complex*16 & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, idiag, isup, isub, mode, maxitr, & nconv logical rvec, first Double precision & tol, rho, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two parameter (one = 1.0D+0 , zero = 0.0D+0 , & two = 2.0D+0 ) c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , dgbmv , daxpy c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-----------------------------------------------------% c | The number NX is the size of each diagonal block of | c | A. The number N(=NX*NX) is the dimension of the | c | matrix. The number N(=NX*NX) is the dimension of | c | the matrix. A generalized eigenvalue problem is | c | solved (BMAT = 'G'). NEV numbers of eigenvalues | c | closest to the COMPLEX shift (SIGMAR,SIGMAI) | c | (WHICH='LM') and their corresponding eigenvectors | c | are computed. The user can modify NX, NEV, NCV, | c | WHICH to solve problems of different sizes, and | c | to get different parts the spectrum. However, the | c | following rules must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-----------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR6: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR6: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR6: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = 4.0D-1 sigmai = 6.0D-1 c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 4 of DNAUPD is used | c | (IPARAm(7) = 4). All these options can be changed | c | by the user. For details, see the documentation | c | in dnband . | c %---------------------------------------------------% c maxitr = 300 mode = 4 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0D+0 m(idiag,j) = 4.0D+0 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 h = one / dble (nx+1) rho = 1.0D+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isub,j+1) = -one+h*rho/two a(isup,j) = -one-h*rho/two 40 continue 50 continue c do 60 j = 1, n-1 m(isub,j+1) = one m(isup,j) = one 60 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one a(isub,j) = -one 70 continue 80 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call dnband (rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, a, m, lda, rfac, cfac, ku, kl, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR6 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call daxpy (n, d(j,2), mx, 1, ax, 1) d(j,3) = dnrm2 (n, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,2), mx, 1, ax, 1) d(j,3) = dlapy2 ( d(j,3), dnrm2 (n, ax, 1) ) d(j,3) = d(j,3) / dlapy2 (d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call dmout (6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for dnband . | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dsbdr1.f0000644000175000017500000002422007174074603017753 0ustar andreasandreas program dsbdr1 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-dimensional Laplacian on the unit square with c zero Dirichlet boundary condition using standard c central difference. c c ... Call DSBAND to find eigenvalues LAMBDA such that c A*x = x*LAMBDA. c c ... Use mode 1 of DSAUPD . c c\BeginLib c c\Routines called: c dsband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr1.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, isub, isup, idiag, maxitr, mode, & nconv Double precision & tol, sigma, h2 logical rvec c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two parameter (one = 1.0D+0 , zero = 0.0D+0 , two = 2.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , dgbmv , daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | Laplacian operator on the unit square with zero | c | Dirichlet boundary condition. The number | c | N(=NX*NX) is the dimension of the matrix. A | c | standard eigenvalue problem is solved | c | (BMAT = 'I'). NEV is the number of eigenvalues | c | to be approximated. The user can modify NX,NEV, | c | NCV and WHICH to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %-------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' c c %-----------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of DSAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | DSBAND . | c %---------------------------------------------------% c maxitr = 300 mode = 1 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h2 = one / ((nx+1)*(nx+1)) idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0D+0 / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one / h2 a(isub,j) = -one / h2 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %-------------------------------------% c | Call DSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call dsband ( rvec, 'A', select, d, v, ldv, sigma, n, a, m, lda, & rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR1 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call daxpy (n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = dnrm2 (n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call dmout (6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DSBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dsbdr2.f0000644000175000017500000002424407526641262017764 0ustar andreasandreas program dsbdr2 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-dimensional Laplacian on the unit square c with zero Dirichlet boundary condition using standard c central difference. c c ... Call DSBAND to find eigenvalues LAMBDA closest to c SIGMA such that c A*x = x*LAMBDA. c c ... Use mode 3 of DSAUPD. c c\BeginLib c c\Routines called: c dsband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr2.F SID: 2.6 DATE OF SID: 07/21/02 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, isub, isup, idiag, maxitr, mode, & nconv Double precision & tol, sigma, h2 logical rvec c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two parameter (one = 1.0D+0, zero = 0.0D+0, two = 2.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2, dnrm2 external dlapy2, dnrm2, daxpy, dgbmv c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | Laplacian operator on the unit square with zero | c | Dirichlet boundary condition. The number | c | N(=NX*NX) is the dimension of the matrix. A | c | standard eigenvalue problem is solved | c | (BMAT = 'I'). NEV is the number of eigenvalues | c | (closest to the shift SIGMA) to be approximated. | c | Since the shift and invert mode is used, WHICH | c | is set to 'LM'. The user can modify NX, NEV, | c | NCV and SIGMA to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigma = zero c c %-----------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv*ncv+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of DSAUPD is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details see the documentation in | c | DSBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset('A', lda, n, zero, zero, a, lda) call dlaset('A', lda, n, zero, zero, m, lda) call dlaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h2 = one / ((nx+1)*(nx+1)) idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0D+0 / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one / h2 a(isub,j) = -one / h2 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %-------------------------------------% c | Call DSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call dsband( rvec,'A', select, d, v, ldv, sigma, n, a, m, & lda, rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR2 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call dgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = dnrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call dmout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DSBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dsbdr3.f0000644000175000017500000002334307174074604017763 0ustar andreasandreas program dsbdr3 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is the 1-dimensional discrete Laplacian on [0,1] c with zero Dirichlet boundary condition, M is the mass c formed by using piecewise linear elements on [0,1]. c c ... Call DSBAND with regular mode to find eigenvalues LAMBDA c such that c A*x = LAMBDA*M*x. c c ... Use mode 2 of DSAUPD . c c\BeginLib c c\Routines called: c dsband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr3.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn), mx(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, isub, isup, idiag, maxitr, mode, nconv Double precision & tol, h, sigma, r1, r2 logical rvec c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two, four, six parameter (one = 1.0D+0 , zero = 0.0D+0 , two = 2.0D+0 , & four = 4.0D+0 , six = 6.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , daxpy , dgbmv c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. The user can modify N, NEV, | c | NCV and WHICH to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' c c %-----------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of DSAUPD is used | c | (IPARAM(7) = 2). All these options can be changed | c | by the user. For details see the documentation in | c | DSBAND . | c %---------------------------------------------------% c maxitr = 300 mode = 2 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / dble (n+1) r1 = four / six idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = r1 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c r2 = one / six isup = kl+ku isub = kl+ku+2 do 60 j = 1, n-1 a(isup,j+1) = -one / h a(isub,j) = -one / h m(isup,j+1) = r2 * h m(isub,j) = r2 * h 60 continue c c %-------------------------------------% c | Call DSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call dsband ( rvec, 'A', select, d, v, ldv, sigma, n, a, m, lda, & rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR3 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = dnrm2 (n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call dmout (6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DSBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dsbdr4.f0000644000175000017500000002343207174074604017763 0ustar andreasandreas program dsbdr4 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is the 1-dimensional discrete Laplacian on [0,1] c with zero Dirichlet boundary condition, M is the mass c formed by using piecewise linear elements on [0,1]. c c ... Call DSBAND with shift-invert mode to find eigenvalues LAMBDA c closest to SIGMA such that c A*x = LAMBDA*M*x. c c ... Use mode 3 of DSAUPD . c c\BeginLib c c\Routines called: c dsband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr4.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn), mx(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, isub, isup, idiag, maxitr, mode, nconv Double precision & tol, h, sigma, r1, r2 logical rvec c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two, four, six parameter (one = 1.0D+0 , zero = 0.0D+0 , two = 2.0D+0 , & four = 4.0D+0 , six = 6.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , daxpy , dgbmv c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | (closest to the shift SIGMA) to be approximated. | c | Since the shift and invert mode is used, WHICH | c | is set to 'LM'. The user can modify N, NEV, NCV | c | and SIGMA to solve problems of different sizes, | c | and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = zero c c %-----------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of DSAUPD is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in DSBAND . | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / dble (n+1) r1 = four / six idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = r1 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c r2 = one / six isup = kl+ku isub = kl+ku+2 do 60 j = 1, n-1 a(isup,j+1) = -one / h a(isub,j) = -one / h m(isup,j+1) = r2 * h m(isub,j) = r2 * h 60 continue c c %-------------------------------------% c | Call DSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call dsband ( rvec, 'A', select, d, v, ldv, sigma, n, a, m, & lda, rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR4 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = dnrm2 (n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call dmout (6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DSBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dsbdr5.f0000644000175000017500000002350107174074604017761 0ustar andreasandreas program dsbdr5 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is the 1-dimensional discrete Laplacian on [0,1] c with zero Dirichlet boundary condition, KG is the mass c formed by using piecewise linear elements on [0,1]. c c ... Call DSBAND with Buckling mode to find eigenvalues LAMBDA c such that c A*x = M*x*LAMBDA. c c ... Use mode 4 of DSAUPD . c c\BeginLib c c\Routines called: c dsband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr5.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn), mx(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, kl, ku, info, j, ido, & n, isub, isup, idiag, maxitr, mode, nconv Double precision & tol, h, sigma, r1, r2 logical rvec c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two, four, six parameter (one = 1.0D+0 , zero = 0.0D+0 , two = 2.0D+0 , & four = 4.0D+0 , six = 6.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , dgbmv , daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. Since the Buckling mode is | c | is used, WHICH is set to 'LM'. The user can | c | modify N, NEV, NCV and SIGMA to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, the following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR5: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR5: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR5: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = 1.0 c c %-----------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 4 of DSAUPD is used | c | (IPARAM(7) = 4). All these options can be changed | c | by the user. For details see the documentation in | c | DSBAND . | c %---------------------------------------------------% c maxitr = 300 mode = 4 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / dble (n+1) r1 = four / six idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = r1 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c r2 = one / six isup = kl+ku isub = kl+ku+2 do 60 j = 1, n-1 a(isup,j+1) = -one / h a(isub,j) = -one / h m(isup,j+1) = r2 * h m(isub,j) = r2 * h 60 continue c c %-------------------------------------% c | Call DSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call dsband ( rvec, 'A', select, d, v, ldv, sigma, n, a, m, lda, & rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR5 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = dnrm2 (n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call dmout (6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DSBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/dsbdr6.f0000644000175000017500000002346107174074605017770 0ustar andreasandreas program dsbdr6 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is the 1-dimensional discrete Laplacian on [0,1] c with zero Dirichlet boundary condition, M is the mass c formed by using piecewise linear elements on [0,1]. c c ... Call DSBAND with Cayley mode to find eigenvalues LAMBDA such that c A*x = LAMBDA*M*x. c c ... Use mode 5 of DSAUPD . c c\BeginLib c c\Routines called: c dsband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlaset LAPACK routine to initialize a matrix to zero. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr6.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Double precision & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn), mx(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, isub, isup, idiag, maxitr, mode, nconv Double precision & tol, h, sigma, r1, r2 logical rvec c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two, four, six parameter (one = 1.0D+0 , zero = 0.0D+0 , two = 2.0D+0 , & four = 4.0D+0 , six = 6.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2 , dnrm2 external dlapy2 , dnrm2 , daxpy , dgbmv c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. Since the Cayley mode is | c | used, WHICH is set to 'LM'. The user can | c | modify N, NEV, NCV and SIGMA to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, the following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR6: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR6: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR6: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = 150.0 c c %-----------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 5 of DSAUPD is used | c | (IPARAM(7) = 5). All these options can be changed | c | by the user. For details, see the documentation | c | in SBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 5 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call dlaset ('A', lda, n, zero, zero, a, lda) call dlaset ('A', lda, n, zero, zero, m, lda) call dlaset ('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / dble (n+1) r1 = four / six idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = r1 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c r2 = one / six isup = kl+ku isub = kl+ku+2 do 60 j = 1, n-1 a(isup,j+1) = -one / h a(isub,j) = -one / h m(isup,j+1) = r2 * h m(isub,j) = r2 * h 60 continue c c %-------------------------------------% c | Call DSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call dsband ( rvec, 'A', select, d, v, ldv, sigma, n, a, m, lda, & rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR6 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call dgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call dgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = dnrm2 (n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call dmout (6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for DSBAND . | c %-------------------------------------% c print *, ' ' print *, ' Error with _band, info= ', info print *, ' Check the documentation of _band ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/snbdr1.f0000644000175000017500000002733607174073766020011 0ustar andreasandreas program snbdr1 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-d convection-diffusion operator c c -Laplacian(u) + rho*partial(u)/partial(x). c c on the unit square with zero Dirichlet boundary condition c using standard central difference. c c ... Call SNBAND to find eigenvalues LAMBDA such that c A*x = LAMBDA*x. c c ... Use mode 1 of SNAUPD. c c\BeginLib c c snband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr1.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn) Complex & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, isub, isup, idiag, mode, maxitr, & nconv logical rvec, first Real & tol, rho, h, h2, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Real & one, zero, two parameter (one = 1.0E+0 , zero = 0.0E+0 , & two = 2.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, sgbmv, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV, WHICH to solve problems of | c | different sizes, and to get different parts the | c | spectrum. However, The following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'SM' c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of SNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details, see the documentation | c | in SNBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 1 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h = one / real (nx+1) h2 = h*h c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0E+0 / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c rho = 1.0E+2 isup = kl+ku isub = kl+ku+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one/h2 + rho/two/h a(isub,j) = -one/h2 - rho/two/h 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call snband(rvec, 'A', select, d, d(1,2), v, ldv, sigmar, sigmai, & workev, n, a, m, lda, rfac, cfac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, workd, & workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR1 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) call saxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call saxpy(n, -d(j,2), v(1,j), 1, ax, 1) call saxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SNBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/snbdr2.f0000644000175000017500000002770107174073767020007 0ustar andreasandreas program snbdr2 c c ... Construct matrices A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-d convection-diffusion operator c c -Laplacian(u) + rho*partial(u)/partial(x). c c on the unit square with zero Dirichlet boundary condition c using standard central difference. c c ... Define the shift SIGMA = (SIGMAR, SIGMAI). c c ... Call SNBAND to find eigenvalues LAMBDA closest to SIGMA c such that c A*x = LAMBDA*x. c c ... Use mode 3 of SNAUPD. c c\BeginLib c c\Routines called: c snband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr2.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c--------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn) Complex & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, idiag, isub, isup, mode, maxitr, & nconv logical rvec, first Real & tol, rho, h2, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Real & one, zero, two parameter (one = 1.0E+0 , zero = 0.0E+0 , & two = 2.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, saxpy, sgbmv c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues (closest to (SIGMAR,SIGMAI)) to be | c | approximated. Since the shift-invert moded is | c | used, WHICH is set to 'LM'. The user can modify | c | NX, NEV, NCV, SIGMAR, SIGMAI to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, The following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigmar = 1.0E+4 sigmai = 0.0E+0 c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of SNAUPD is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in SNBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h = one / real (nx+1) h2 = h*h c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0E+0 / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = 1.0E+1 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isub,j+1) = -one/h2 + rho/two/h a(isup,j) = -one/h2 - rho/two/h 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call snband(rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, a, m, lda, rfac, cfac, kl, ku, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR2 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) call saxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) call saxpy(n, -d(j,2), v(1,j), 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SNBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/snbdr3.f0000644000175000017500000002760207174073767020010 0ustar andreasandreas program snbdr3 c c ... Construct matrices A and M in LAPACK-style band form. c The matrix A and M are derived from the finite element c discretization of the 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition, c ... Call SNBAND to find eigenvalues LAMBDA such that c A*x = LAMBDA*M*x. c c ... Eigenvalues with largest real parts are sought. c c ... Use mode 2 of SNAUPD. c c\BeginLib c c\Routines called: c snband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr3.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c------------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn), mx(maxn) Complex & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, idiag, isup, isub, mode, maxitr, & nconv logical rvec, first Real & tol, rho, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Real & one, zero, two parameter (one = 1.0E+0 , zero = 0.0E+0 , & two = 2.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, sgbmv, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. The user can modify N, NEV, | c | NCV and WHICH to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' c c %----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL has to be set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine machine | c | precision is used. The number IDO is used for | c | reverse communication and has to be set to 0 at | c | the beginning. Setting INFO=0 indicates that we | c | using a randomly generated vector to start the | c | the ARNOLDI process. | c %----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv info = 0 tol = zero ido = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of SNAUPD is used | c | (IPARAM(7) = 2). All these options can be changed | c | by the user. For details, see the documentation | c | in SNBAND. | c %---------------------------------------------------% c mode = 2 maxitr = 300 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / real (n+1) c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 2.0E+0 / h m(idiag,j) = 4.0E+0 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = 1.0E+1 do 50 j = 1, n a(isup,j+1) = -one/h + rho/two a(isub,j) = -one/h - rho/two m(isup,j+1) = one*h m(isub,j) = one*h 50 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call snband( rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, A, M, lda, rfac, cfac, kl, ku, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR3 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call saxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SNBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/snbdr4.f0000644000175000017500000002764407172771750020012 0ustar andreasandreas program snbdr4 c c ... Construct matrices A and M in LAPACK-style band form. c The matrix A and M are derived from the finite element c discretization of the 1-dimensional convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition. c c ... Define the shift SIGMA = (SIGMAR, SIGMAI). c c ... Call SNBAND to find eigenvalues LAMBDA closest to SIGMA c such that c A*x = LAMBDA*M*x. c c ... Use mode 3 of SNAUPD. c c\BeginLib c c\Routines called: c snband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr4.F SID: 2.6 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn), mx(maxn) Complex & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, idiag, isup, isub, mode, maxitr, & nconv logical rvec, first Real & tol, rho, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Real & one, zero, two, six parameter (one = 1.0E+0, zero = 0.0E+0, & two = 2.0E+0, six = 6.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, sgbmv, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. The user can modify N, NEV, | c | NCV and WHICH to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = 1.0E+1 sigmai = 0.0E+0 c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv info = 0 tol = zero ido = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of snaupd is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in snaupd. | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = n iparam(7) = 3 c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / real(n+1) idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 2.0E+0 / h m(idiag,j) = 4.0E+0 * h / six 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = 1.0E+1 do 40 j = 1, n-1 a(isup,j+1) = -one/h + rho/two a(isub,j) = -one/h - rho/two m(isup,j+1) = one*h/six m(isub,j) = one*h/six 40 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call snband(rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, A, M, lda, rfac, cfac, kl, ku, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR4 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 50 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call saxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 50 continue call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relatve residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SNBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/snbdr5.f0000644000175000017500000002763607174073770020013 0ustar andreasandreas program snbdr5 c c ... Construct matrices A and M in LAPACK-style band form. c The matrix A is a block tridiagonal matrix. Each c diagonal block is a tridiagonal matrix with c 4 on the diagonal, 1-rho*h/2 on the subdiagonal and c 1+rho*h/2 on the superdiagonal. Each off-diagonal block c of A is an identity matrices. c c ... Define COMPLEX shift SIGMA = (SIGMAR,SIGMAI), SIGMAI .ne. 0. c c ... Call SNBAND to find eigenvalues LAMBDA closest to SIGMA c such that c A*x = LAMBDA*x. c c ... Use mode 4 of SNAUPD. c c\BeginLib c c\Routines called: c snband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr5.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c------------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn) Complex & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, idiag, isup, isub, mode, maxitr, & nconv logical rvec, first Real & tol, rho, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Real & one, zero, two parameter (one = 1.0E+0 , zero = 0.0E+0 , & two = 2.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, sgbmv, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number NX is the size of each block diagonal | c | of A. The number N(=NX*NX) is the dimension of | c | the matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues (closest to (SIGMAR,SIGMAI)) to be | c | approximated. Since the shift-invert moded is | c | used, WHICH is set to 'LM'. The user can modify | c | NX, NEV, NCV, SIGMAR, SIGMAI to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, The following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR5: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR5: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR5: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigmar = 4.0E-1 sigmai = 6.0E-1 c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 4 of SNAUPD is used | c | (IPARAM(7) = 4). All these options can be changed | c | by the user. For details, see the documentation | c | in SNBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 4 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0E+0 m(idiag,j) = 4.0E+0 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+kl+2 h = one / real (nx+1) rho = 1.0E+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one+h*rho/two a(isub,j) = -one-h*rho/two 40 continue 50 continue c do 60 j = 1, n-1 m(isup,j+1) = one m(isub,j) = one 60 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one a(isub,j) = -one 70 continue 80 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call snband(rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, a, m, lda, rfac, cfac, ku, kl, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR5 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) call saxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) call saxpy(n, -d(j,2), v(1,j), 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SNBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/snbdr6.f0000644000175000017500000003147407174073770020007 0ustar andreasandreas program snbdr6 c c ... Construct matrices A and M in LAPACK-style band form. c The matrix A is a block tridiagonal matrix. Each c diagonal block is a tridiagonal matrix with c 4 on the diagonal, 1-rho*h/2 on the subdiagonal and c 1+rho*h/2 on the superdiagonal. Each subdiagonal block c of A is an identity matrix. The matrix M is the c tridiagonal matrix with 4 on the diagonal and 1 on the c subdiagonal and superdiagonal. c c ... Define COMPLEX shift SIGMA=(SIGMAR,SIGMAI), SIGMAI .ne. zero. c c ... Call snband to find eigenvalues LAMBDA closest to SIGMA c such that c A*x = LAMBDA*M*x. c c ... Use mode 4 of SNAUPD. c c\BeginLib c c\Routines called: c snband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr6.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c--------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & workev(3*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv, 3), ax(maxn), mx(maxn) Complex & cfac(lda, maxn), workc(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, idiag, isup, isub, mode, maxitr, & nconv logical rvec, first Real & tol, rho, h, sigmar, sigmai c c %------------% c | Parameters | c %------------% c Real & one, zero, two parameter (one = 1.0E+0 , zero = 0.0E+0 , & two = 2.0E+0 ) c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, sgbmv, saxpy c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-----------------------------------------------------% c | The number NX is the size of each diagonal block of | c | A. The number N(=NX*NX) is the dimension of the | c | matrix. The number N(=NX*NX) is the dimension of | c | the matrix. A generalized eigenvalue problem is | c | solved (BMAT = 'G'). NEV numbers of eigenvalues | c | closest to the COMPLEX shift (SIGMAR,SIGMAI) | c | (WHICH='LM') and their corresponding eigenvectors | c | are computed. The user can modify NX, NEV, NCV, | c | WHICH to solve problems of different sizes, and | c | to get different parts the spectrum. However, the | c | following rules must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-----------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR6: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR6: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR6: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = 4.0E-1 sigmai = 6.0E-1 c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 4 of SNAUPD is used | c | (IPARAm(7) = 4). All these options can be changed | c | by the user. For details, see the documentation | c | in snband. | c %---------------------------------------------------% c maxitr = 300 mode = 4 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0E+0 m(idiag,j) = 4.0E+0 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 h = one / real (nx+1) rho = 1.0E+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isub,j+1) = -one+h*rho/two a(isup,j) = -one-h*rho/two 40 continue 50 continue c do 60 j = 1, n-1 m(isub,j+1) = one m(isup,j) = one 60 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one a(isub,j) = -one 70 continue 80 continue c c %------------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. The real parts of the | c | eigenvalues are returned in the first column | c | of D, the imaginary parts are returned in the | c | second column of D. Eigenvectors are returned | c | in the first NCONV (=IPARAM(5)) columns of V. | c %------------------------------------------------% c rvec = .true. call snband(rvec, 'A', select, d, d(1,2), v, ldv, sigmar, & sigmai, workev, n, a, m, lda, rfac, cfac, ku, kl, & which, bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, workc, iwork, info) c if ( info .eq. 0) then c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c nconv = iparam(5) c print *, ' ' print *, ' _NBDR6 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c first = .true. do 90 j = 1, nconv c if ( d(j,2) .eq. zero ) then c c %--------------------% c | Ritz value is real | c %--------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if ( first ) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call saxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j+1), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j+1), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 90 continue call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for snband. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/ssbdr1.f0000644000175000017500000002410307174074603017772 0ustar andreasandreas program ssbdr1 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-dimensional Laplacian on the unit square with c zero Dirichlet boundary condition using standard c central difference. c c ... Call SSBAND to find eigenvalues LAMBDA such that c A*x = x*LAMBDA. c c ... Use mode 1 of SSAUPD. c c\BeginLib c c\Routines called: c ssband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr1.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, isub, isup, idiag, maxitr, mode, & nconv Real & tol, sigma, h2 logical rvec c c %------------% c | Parameters | c %------------% c Real & one, zero, two parameter (one = 1.0E+0 , zero = 0.0E+0 , two = 2.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, sgbmv, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | Laplacian operator on the unit square with zero | c | Dirichlet boundary condition. The number | c | N(=NX*NX) is the dimension of the matrix. A | c | standard eigenvalue problem is solved | c | (BMAT = 'I'). NEV is the number of eigenvalues | c | to be approximated. The user can modify NX,NEV, | c | NCV and WHICH to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %-------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' c c %-----------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of SSAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | SSBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 1 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h2 = one / ((nx+1)*(nx+1)) idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0E+0 / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one / h2 a(isub,j) = -one / h2 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %-------------------------------------% c | Call SSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call ssband( rvec, 'A', select, d, v, ldv, sigma, n, a, m, lda, & rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR1 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SSBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/ssbdr2.f0000644000175000017500000002416407526641262020004 0ustar andreasandreas program ssbdr2 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-dimensional Laplacian on the unit square c with zero Dirichlet boundary condition using standard c central difference. c c ... Call SSBAND to find eigenvalues LAMBDA closest to c SIGMA such that c A*x = x*LAMBDA. c c ... Use mode 3 of SSAUPD. c c\BeginLib c c\Routines called: c ssband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr2.F SID: 2.6 DATE OF SID: 07/21/02 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(3*maxncv*maxncv+6*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, i, j, ido, & n, nx, lo, isub, isup, idiag, maxitr, mode, & nconv Real & tol, sigma, h2 logical rvec c c %------------% c | Parameters | c %------------% c Real & one, zero, two parameter (one = 1.0E+0, zero = 0.0E+0, two = 2.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, saxpy, sgbmv c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | Laplacian operator on the unit square with zero | c | Dirichlet boundary condition. The number | c | N(=NX*NX) is the dimension of the matrix. A | c | standard eigenvalue problem is solved | c | (BMAT = 'I'). NEV is the number of eigenvalues | c | (closest to the shift SIGMA) to be approximated. | c | Since the shift and invert mode is used, WHICH | c | is set to 'LM'. The user can modify NX, NEV, | c | NCV and SIGMA to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigma = zero c c %-----------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv*ncv+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of SSAUPD is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details see the documentation in | c | SSBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h2 = one / ((nx+1)*(nx+1)) idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = 4.0E+0 / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one / h2 a(isub,j) = -one / h2 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %-------------------------------------% c | Call SSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call ssband( rvec,'A', select, d, v, ldv, sigma, n, a, m, & lda, rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR2 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SSBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/ssbdr3.f0000644000175000017500000002322507174074603020000 0ustar andreasandreas program ssbdr3 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is the 1-dimensional discrete Laplacian on [0,1] c with zero Dirichlet boundary condition, M is the mass c formed by using piecewise linear elements on [0,1]. c c ... Call SSBAND with regular mode to find eigenvalues LAMBDA c such that c A*x = LAMBDA*M*x. c c ... Use mode 2 of SSAUPD. c c\BeginLib c c\Routines called: c ssband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr3.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn), mx(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, isub, isup, idiag, maxitr, mode, nconv Real & tol, h, sigma, r1, r2 logical rvec c c %------------% c | Parameters | c %------------% c Real & one, zero, two, four, six parameter (one = 1.0E+0 , zero = 0.0E+0 , two = 2.0E+0 , & four = 4.0E+0 , six = 6.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, saxpy, sgbmv c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. The user can modify N, NEV, | c | NCV and WHICH to solve problems of different | c | sizes, and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' c c %-----------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of SSAUPD is used | c | (IPARAM(7) = 2). All these options can be changed | c | by the user. For details see the documentation in | c | SSBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 2 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / real (n+1) r1 = four / six idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = r1 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c r2 = one / six isup = kl+ku isub = kl+ku+2 do 60 j = 1, n-1 a(isup,j+1) = -one / h a(isub,j) = -one / h m(isup,j+1) = r2 * h m(isub,j) = r2 * h 60 continue c c %-------------------------------------% c | Call SSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call ssband( rvec, 'A', select, d, v, ldv, sigma, n, a, m, lda, & rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR3 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SSBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/ssbdr4.f0000644000175000017500000002331407174074604020001 0ustar andreasandreas program ssbdr4 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is the 1-dimensional discrete Laplacian on [0,1] c with zero Dirichlet boundary condition, M is the mass c formed by using piecewise linear elements on [0,1]. c c ... Call SSBAND with shift-invert mode to find eigenvalues LAMBDA c closest to SIGMA such that c A*x = LAMBDA*M*x. c c ... Use mode 3 of SSAUPD. c c\BeginLib c c\Routines called: c ssband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr4.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn), mx(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, isub, isup, idiag, maxitr, mode, nconv Real & tol, h, sigma, r1, r2 logical rvec c c %------------% c | Parameters | c %------------% c Real & one, zero, two, four, six parameter (one = 1.0E+0 , zero = 0.0E+0 , two = 2.0E+0 , & four = 4.0E+0 , six = 6.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, saxpy, sgbmv c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | (closest to the shift SIGMA) to be approximated. | c | Since the shift and invert mode is used, WHICH | c | is set to 'LM'. The user can modify N, NEV, NCV | c | and SIGMA to solve problems of different sizes, | c | and to get different parts the spectrum. | c | However, the following conditions must be | c | satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = zero c c %-----------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of SSAUPD is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in SSBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / real (n+1) r1 = four / six idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = r1 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c r2 = one / six isup = kl+ku isub = kl+ku+2 do 60 j = 1, n-1 a(isup,j+1) = -one / h a(isub,j) = -one / h m(isup,j+1) = r2 * h m(isub,j) = r2 * h 60 continue c c %-------------------------------------% c | Call SSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call ssband( rvec, 'A', select, d, v, ldv, sigma, n, a, m, & lda, rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR4 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SSBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/ssbdr5.f0000644000175000017500000002336307174074604020006 0ustar andreasandreas program ssbdr5 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is the 1-dimensional discrete Laplacian on [0,1] c with zero Dirichlet boundary condition, KG is the mass c formed by using piecewise linear elements on [0,1]. c c ... Call SSBAND with Buckling mode to find eigenvalues LAMBDA c such that c A*x = M*x*LAMBDA. c c ... Use mode 4 of SSAUPD. c c\BeginLib c c\Routines called: c ssband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr5.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn), mx(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, kl, ku, info, j, ido, & n, isub, isup, idiag, maxitr, mode, nconv Real & tol, h, sigma, r1, r2 logical rvec c c %------------% c | Parameters | c %------------% c Real & one, zero, two, four, six parameter (one = 1.0E+0 , zero = 0.0E+0 , two = 2.0E+0 , & four = 4.0E+0 , six = 6.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, sgbmv, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. Since the Buckling mode is | c | is used, WHICH is set to 'LM'. The user can | c | modify N, NEV, NCV and SIGMA to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, the following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR5: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR5: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR5: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = 1.0 c c %-----------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 4 of SSAUPD is used | c | (IPARAM(7) = 4). All these options can be changed | c | by the user. For details see the documentation in | c | SSBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 4 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / real (n+1) r1 = four / six idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = r1 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c r2 = one / six isup = kl+ku isub = kl+ku+2 do 60 j = 1, n-1 a(isup,j+1) = -one / h a(isub,j) = -one / h m(isup,j+1) = r2 * h m(isub,j) = r2 * h 60 continue c c %-------------------------------------% c | Call SSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call ssband( rvec, 'A', select, d, v, ldv, sigma, n, a, m, lda, & rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR5 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SSBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _sband, info= ', info print *, ' Check the documentation of _sband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/ssbdr6.f0000644000175000017500000002334407174074605020007 0ustar andreasandreas program ssbdr6 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is the 1-dimensional discrete Laplacian on [0,1] c with zero Dirichlet boundary condition, M is the mass c formed by using piecewise linear elements on [0,1]. c c ... Call SSBAND with Cayley mode to find eigenvalues LAMBDA such that c A*x = LAMBDA*M*x. c c ... Use mode 5 of SSAUPD. c c\BeginLib c c\Routines called: c ssband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slaset LAPACK routine to initialize a matrix to zero. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sbdr6.F SID: 2.5 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Real & a(lda,maxn), m(lda,maxn), rfac(lda,maxn), & workl(maxncv*maxncv+8*maxncv), workd(3*maxn), & v(ldv, maxncv), resid(maxn), d(maxncv, 2), & ax(maxn), mx(maxn) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, ido, & n, isub, isup, idiag, maxitr, mode, nconv Real & tol, h, sigma, r1, r2 logical rvec c c %------------% c | Parameters | c %------------% c Real & one, zero, two, four, six parameter (one = 1.0E+0 , zero = 0.0E+0 , two = 2.0E+0 , & four = 4.0E+0 , six = 6.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, saxpy, sgbmv c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved | c | (BMAT = 'G'). NEV is the number of eigenvalues | c | to be approximated. Since the Cayley mode is | c | used, WHICH is set to 'LM'. The user can | c | modify N, NEV, NCV and SIGMA to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, the following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SBDR6: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SBDR6: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SBDR6: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = 150.0 c c %-----------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv**2+8*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 5 of SSAUPD is used | c | (IPARAM(7) = 5). All these options can be changed | c | by the user. For details, see the documentation | c | in SBAND. | c %---------------------------------------------------% c maxitr = 300 mode = 5 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call slaset('A', lda, n, zero, zero, a, lda) call slaset('A', lda, n, zero, zero, m, lda) call slaset('A', lda, n, zero, zero, rfac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / real (n+1) r1 = four / six idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = r1 * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c r2 = one / six isup = kl+ku isub = kl+ku+2 do 60 j = 1, n-1 a(isup,j+1) = -one / h a(isub,j) = -one / h m(isup,j+1) = r2 * h m(isub,j) = r2 * h 60 continue c c %-------------------------------------% c | Call SSBAND to find eigenvalues and | c | eigenvectors. Eigenvalues are | c | returned in the first column of D. | c | Eigenvectors are returned in the | c | first NCONV (=IPARAM(5)) columns of | c | V. | c %-------------------------------------% c rvec = .true. call ssband( rvec, 'A', select, d, v, ldv, sigma, n, a, m, lda, & rfac, kl, ku, which, bmat, nev, tol, & resid, ncv, v, ldv, iparam, workd, workl, lworkl, & iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, ' _SBDR6 ' print *, ' ====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Lanczos vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv call sgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call sgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 90 continue call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for SSBAND. | c %-------------------------------------% c print *, ' ' print *, ' Error with _band, info= ', info print *, ' Check the documentation of _band ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/makefile0000644000175000017500000001151506221770460020124 0ustar andreasandreas# # makefile to run simple examples of the reverse communication # protocol. # # Modify if ARPACK library was built somewhere else. # # If ALIBS (defined in ../../ARmake.inc) contains the BLAS and LAPACK # libraries installed on your system, you DO NOT need to change this # makefile. OTHERWISE, you may need to modify the Makefile in the top level # ARPACK directory tree to include sdrv, ddrv, cdrv, or zdrv in the # definition of the PRECISION variable, and issue 'make lib' there. # For example: # # PRECISION = single double sdrv ddrv # #\SCCS Information: @(#) # FILE: makefile SID: 2.2 DATE OF SID: 9/24/96 RELEASE: 2 # include ../../ARmake.inc # Issue "make band" to make all 32 band drivers. # Issue "make ssbdr" to make 6 single precision symmetric band drivers. # Issue "make dsbdr" to make 6 double precision symmetric band drivers. # Issue "make snbdr" to make 6 single precision nonsymmetric band drivers. # Issue "make dnbdr" to make 6 double precision nonsymmetric band drivers. # Issue "make cnbdr" to make 4 single precision complex band drivers. # Issue "make znbdr" to make 4 double precision complex band drivers. # band: ssbdr dsbdr snbdr dnbdr cnbdr znbdr # #--------------------------------------------------------------------- # Simple symetric problem using BAND solver (single precision) # ssbdr: ssbdr1 ssbdr2 ssbdr3 ssbdr4 ssbdr5 ssbdr6 ssbdr1: ssbdr1.o ssband.o $(FC) $(FFLAGS) ssbdr1.o ssband.o $(ALIBS) -o ssbdr1 # ssbdr2: ssbdr2.o ssband.o $(FC) $(FFLAGS) ssbdr2.o ssband.o $(ALIBS) -o ssbdr2 # ssbdr3: ssbdr3.o ssband.o $(FC) $(FFLAGS) ssbdr3.o ssband.o $(ALIBS) -o ssbdr3 # ssbdr4: ssbdr4.o ssband.o $(FC) $(FFLAGS) ssbdr4.o ssband.o $(ALIBS) -o ssbdr4 # ssbdr5: ssbdr5.o ssband.o $(FC) $(FFLAGS) ssbdr5.o ssband.o $(ALIBS) -o ssbdr5 # ssbdr6: ssbdr6.o ssband.o $(FC) $(FFLAGS) ssbdr6.o ssband.o $(ALIBS) -o ssbdr6 # #------------------------------------------------------------- # # Simple symmetric problem using BAND solver (double precision) # dsbdr: dsbdr1 dsbdr2 dsbdr3 dsbdr4 dsbdr5 dsbdr6 dsbdr1: dsbdr1.o dsband.o $(FC) $(FFLAGS) dsbdr1.o dsband.o $(ALIBS) -o dsbdr1 # dsbdr2: dsbdr2.o dsband.o $(FC) $(FFLAGS) dsbdr2.o dsband.o $(ALIBS) -o dsbdr2 # dsbdr3: dsbdr3.o dsband.o $(FC) $(FFLAGS) dsbdr3.o dsband.o $(ALIBS) -o dsbdr3 # dsbdr4: dsbdr4.o dsband.o $(FC) $(FFLAGS) dsbdr4.o dsband.o $(ALIBS) -o dsbdr4 # dsbdr5: dsbdr5.o dsband.o $(FC) $(FFLAGS) dsbdr5.o dsband.o $(ALIBS) -o dsbdr5 # dsbdr6: dsbdr6.o dsband.o $(FC) $(FFLAGS) dsbdr6.o dsband.o $(ALIBS) -o dsbdr6 # #---------------------------------------------------------------------- # Simple nonsymmetric problem using BAND solver (single precision) # snbdr: snbdr1 snbdr2 snbdr3 snbdr4 snbdr5 snbdr6 snbdr1: snbdr1.o snband.o $(FC) $(FFLAGS) snbdr1.o snband.o $(ALIBS) -o snbdr1 # snbdr2: snbdr2.o snband.o $(FC) $(FFLAGS) snbdr2.o snband.o $(ALIBS) -o snbdr2 # snbdr3: snbdr3.o snband.o $(FC) $(FFLAGS) snbdr3.o snband.o $(ALIBS) -o snbdr3 # snbdr4: snbdr4.o snband.o $(FC) $(FFLAGS) snbdr4.o snband.o $(ALIBS) -o snbdr4 # snbdr5: snbdr5.o snband.o $(FC) $(FFLAGS) snbdr5.o snband.o $(ALIBS) -o snbdr5 # snbdr6: snbdr6.o snband.o $(FC) $(FFLAGS) snbdr6.o snband.o $(ALIBS) -o snbdr6 # #------------------------------------------------------------------------- # Simple nonsymmetric problem using BAND solver (double precision) # dnbdr: dnbdr1 dnbdr2 dnbdr3 dnbdr4 dnbdr5 dnbdr6 dnbdr1: dnbdr1.o dnband.o $(FC) $(FFLAGS) dnbdr1.o dnband.o $(ALIBS) -o dnbdr1 # dnbdr2: dnbdr2.o dnband.o $(FC) $(FFLAGS) dnbdr2.o dnband.o $(ALIBS) -o dnbdr2 # dnbdr3: dnbdr3.o dnband.o $(FC) $(FFLAGS) dnbdr3.o dnband.o $(ALIBS) -o dnbdr3 # dnbdr4: dnbdr4.o dnband.o $(FC) $(FFLAGS) dnbdr4.o dnband.o $(ALIBS) -o dnbdr4 # dnbdr5: dnbdr5.o dnband.o $(FC) $(FFLAGS) dnbdr5.o dnband.o $(ALIBS) -o dnbdr5 # dnbdr6: dnbdr6.o dnband.o $(FC) $(FFLAGS) dnbdr6.o dnband.o $(ALIBS) -o dnbdr6 # #------------------------------------------------------------------------- # Complex problem using BAND solver (single precision complex) # cnbdr: cnbdr1 cnbdr2 cnbdr3 cnbdr4 cnbdr1: cnbdr1.o cnband.o $(FC) $(FFLAGS) cnbdr1.o cnband.o $(ALIBS) -o cnbdr1 # cnbdr2: cnbdr2.o cnband.o $(FC) $(FFLAGS) cnbdr2.o cnband.o $(ALIBS) -o cnbdr2 # cnbdr3: cnbdr3.o cnband.o $(FC) $(FFLAGS) cnbdr3.o cnband.o $(ALIBS) -o cnbdr3 # cnbdr4: cnbdr4.o cnband.o $(FC) $(FFLAGS) cnbdr4.o cnband.o $(ALIBS) -o cnbdr4 # #------------------------------------------------------------------------- # Complex problem using BAND solver (double precision complex) # znbdr: znbdr1 znbdr2 znbdr3 znbdr4 znbdr1: znbdr1.o znband.o $(FC) $(FFLAGS) znbdr1.o znband.o $(ALIBS) -o znbdr1 # znbdr2: znbdr2.o znband.o $(FC) $(FFLAGS) znbdr2.o znband.o $(ALIBS) -o znbdr2 # znbdr3: znbdr3.o znband.o $(FC) $(FFLAGS) znbdr3.o znband.o $(ALIBS) -o znbdr3 # znbdr4: znbdr4.o znband.o $(FC) $(FFLAGS) znbdr4.o znband.o $(ALIBS) -o znbdr4 arpack-akloeckner-07/EXAMPLES/BAND/cnbdr1.f0000644000175000017500000002476307174075122017756 0ustar andreasandreas program cnbdr1 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-d convection-diffusion operator c c -Laplacian(u) + rho*partial(u)/partial(x). c c on the unit square with zero Dirichlet boundary condition c using standard central difference. c c ... Call CNBAND to find eigenvalues LAMBDA such that c A*x = x*LAMBDA. c c ... Use mode 1 of CNAUPD. c c\BeginLib c c cnband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c claset LAPACK routine to initialize a matrix to zero. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c scnrm2 Level 1 BLAS that computes the norm of a vector. c cgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr1.F SID: 2.3 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Complex & a(lda,maxn), m(lda,maxn), fac(lda,maxn), & workl(3*maxncv*maxncv+5*maxncv), workd(3*maxn), & workev(2*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv), ax(maxn) Real & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, kl, ku, info, i, j, & n, nx, lo, isub, isup, idiag, maxitr, mode, & nconv logical rvec Real & tol Complex & rho, h, h2, sigma c c %------------% c | Parameters | c %------------% c Complex & one, zero, two parameter ( one = (1.0E+0, 0.0E+0) , & zero = (0.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external scnrm2, cgbmv, caxpy, slapy2, claset c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV and WHICH to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, the following | c | conditions must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' c c %-----------------------------------------------------% c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. Setting INFO=0 indicates that a | c | random vector is generated in CNAUPD to start the | c | Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of CNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details, see the documentation | c | in cnband. | c %---------------------------------------------------% c maxitr = 300 mode = 1 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call claset('A', lda, n, zero, zero, a, lda) call claset('A', lda, n, zero, zero, m, lda) call claset('A', lda, n, zero, zero, fac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h = one / cmplx(nx+1) h2 = h*h c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = (4.0E+0, 0.0E+0) / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c rho = (1.0E+2, 0.0E+0) isup = kl+ku isub = kl+ku+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one/h2 + rho/two/h a(isub,j) = -one/h2 - rho/two/h 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %-----------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. Eigenvalues are returned in | c | the one dimensional array D. Eigenvectors | c | are returned in the first NCONV (=IPARAM(5)) | c | columns of V. | c %-----------------------------------------------% c rvec = .true. call cnband(rvec, 'A', select, d, v, ldv, sigma, & workev, n, a, m, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, '_NBDR1 ' print *, '====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv c c %---------------------------% c | Compute the residual norm | c | || A*x - lambda*x || | c %---------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call caxpy(n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1),rd(j,2)) 90 continue call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for cnband. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/cnbdr2.f0000644000175000017500000002520507174076041017750 0ustar andreasandreas program cnbdr2 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-d convection-diffusion operator c c -Laplacian(u) + rho*partial(u)/partial(x). c c on the unit square with zero Dirichlet boundary condition c using standard central difference. c c ... Call CNBAND to find eigenvalues LAMBDA such that c A*x = x*LAMBDA. c c ... Use mode 3 of CNAUPD. c c\BeginLib c c cnband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c claset LAPACK routine to initialize a matrix to zero. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c scnrm2 Level 1 BLAS that computes the norm of a vector. c cgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr2.F SID: 2.4 DATE OF SID: 10/20/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Complex & a(lda,maxn), m(lda,maxn), fac(lda,maxn), & workl(3*maxncv*maxncv+5*maxncv), workd(3*maxn), & workev(2*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv), ax(maxn) Real & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, kl, ku, info, i, j, & n, nxi, lo, isub, isup, idiag, maxitr, mode, & nconv logical rvec Real & tol Complex & rho, h, h2, sigma c c %------------% c | Parameters | c %------------% c Complex & one, zero, two parameter (one = (1.0E+0, 0.0E+0) , & zero = (0.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external scnrm2, cgbmv, caxpy, slapy2, claset c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues (closest to SIGMA) to be | c | approximated. Since the shift and invert mode | c | is used, WHICH is set to 'LM'. The user can | c | modify NX, NEV and NCV to solve problems of | c | different sizes, and to get different parts the | c | spectrum. However, the following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c nxi = 10 n = nxi*nxi nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigma = zero c c %-----------------------------------------------------% c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. Setting INFO=0 indicates that a | c | random vector is generated in CNAUPD to start the | c | Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of CNAUPD is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in cnband. | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call claset('A', lda, n, zero, zero, a, lda) call claset('A', lda, n, zero, zero, m, lda) call claset('A', lda, n, zero, zero, fac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nxi ku = nxi c c %---------------% c | Main diagonal | c %---------------% c h = one / cmplx(nxi+1) h2 = h*h c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = (4.0E+0, 0.0E+0) / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c rho = (1.0E+2, 0.0E+0) isup = kl+ku isub = kl+ku+2 do 50 i = 1, nxi lo = (i-1)*nxi do 40 j = lo+1, lo+nxi-1 a(isup,j+1) = -one/h2 + rho/two/h a(isub,j) = -one/h2 - rho/two/h 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nxi-1 lo = (i-1)*nxi do 70 j = lo+1, lo+nxi a(isup,nxi+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %-----------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. Eigenvalues are returned in | c | the one dimensional array D. Eigenvectors | c | are returned in the first NCONV (=IPARAM(5)) | c | columns of V. | c %-----------------------------------------------% c rvec = .true. call cnband(rvec, 'A', select, d, v, ldv, sigma, & workev, n, a, m, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, '_NBDR2 ' print *, '====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv c c %---------------------------% c | Compute the residual norm | c | || A*x - lambda*x || | c %---------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call caxpy(n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1),rd(j,2)) 90 continue call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for cnband. | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/cnbdr3.f0000644000175000017500000002427307174076045017761 0ustar andreasandreas program cnbdr3 c c ... Construct matrices A and M in LAPACK-style band form. c Matrices A and M are derived from the finite c element discretization of the 1-dimensional c convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition using c piecewise linear elements. c c ... Call CNBAND to find eigenvalues LAMBDA such that c A*x = M*x*LAMBDA. c c ... Eigenvalues with largest real parts are sought. c c ... Use mode 2 of CNAUPD. c c\BeginLib c c\Routines called: c cnband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c claset LAPACK routine to initialize a matrix to zero. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c scnrm2 Level 1 BLAS that computes the norm of a vector. c cgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr3.F SID: 2.4 DATE OF SID: 10/20/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c------------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Complex & a(lda,maxn), m(lda,maxn), fac(lda,maxn), & workl(3*maxncv*maxncv+5*maxncv), workd(3*maxn), & workev(2*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv), ax(maxn), mx(maxn) Real & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, & n, idiag, isup, isub, maxitr, & mode, nconv logical rvec Real & tol Complex & rho, h, sigma c c %------------% c | Parameters | c %------------% c Complex & one, zero, two parameter (one = (1.0E+0, 0.0E+0) , & zero = (0.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external scnrm2, cgbmv, caxpy, slapy2, claset c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A generalized eigenvalue problem is | c | solved (BMAT = 'G'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV and WHICH to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = zero c c %----------------------------------------------------% c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL has to be set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine machine | c | precision is used. Setting INFO=0 indicates that | c | using a randomly generated vector to start the | c | the ARNOLDI process. | c %----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv info = 0 tol = 0.0 c c %---------------------------------------------------% c | IPARAm(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of CNAUPD is used | c | (IPARAm(7) = 2). All these options can be changed | c | by the user. For details, see the documentation | c | in cnband. | c %---------------------------------------------------% c maxitr = 300 mode = 2 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call claset('A', lda, n, zero, zero, a, lda) call claset('A', lda, n, zero, zero, m, lda) call claset('A', lda, n, zero, zero, fac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / cmplx(n+1) c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = (2.0E+0, 0.0E+0) / h m(idiag,j) = (4.0E+0, 0.0E+0) * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = (1.0E+1, 0.0E+0) do 40 j = 1, n-1 a(isup,j+1) = -one/h + rho/two a(isub,j) = -one/h - rho/two m(isup,j+1) = one*h m(isub,j) = one*h 40 continue c c %-----------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. Eigenvalues are returned in | c | the one dimensional array D. Eigenvectors | c | are returned in the first NCONV (=IPARAM(5)) | c | columns of V. | c %-----------------------------------------------% c rvec = .true. call cnband(rvec, 'A', select, d, v, ldv, sigma, & workev, n, a, m, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, '_NBDR3 ' print *, '====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c do 50 j = 1, nconv c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call cgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call caxpy(n, -d(j), mx, 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1), rd(j,2)) 50 continue call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for cnband. | c %-------------------------------------% c print *, ' ' print *, ' Error with _band, info= ', info print *, ' Check the documentation of _band ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/cnbdr4.f0000644000175000017500000002451107174077530017755 0ustar andreasandreas program cndrv4 c c ... Construct matrices A and M in LAPACK-style band form. c Matries A and M are derived from the finite c element discretization of the 1-dimensional c convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition using c piecewise linear elements. c c ... Call CNBAND to find eigenvalues LAMBDA such that c A*x = M*x*LAMBDA. c c ... Use mode 3 of CNAUPD. c c\BeginLib c c\Routines called: c cnband ARPACK banded eigenproblem solver. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c claset LAPACK routine to initialize a matrix to zero. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c scnrm2 Level 1 BLAS that computes the norm of a vector. c cgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr4.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c------------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Complex & a(lda,maxn), m(lda,maxn), fac(lda,maxn), & workl(3*maxncv*maxncv+5*maxncv), workd(3*maxn), & workev(2*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv), ax(maxn), mx(maxn) Real & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, & n, idiag, isup, isub, maxitr, mode, & nconv logical rvec Real & tol Complex & rho, h, sigma c c %------------% c | Parameters | c %------------% c Complex & one, zero, two, four, six parameter (one = (1.0E+0, 0.0E+0) , & zero = (0.0E+0, 0.0E+0) , & two = (2.0E+0, 0.0E+0) , & four = (4.0E+0, 0.0E+0) , & six = (6.0E+0, 0.0E+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external scnrm2, cgbmv, caxpy, slapy2, claset c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A generalized eigenvalue problem is | c | solved (BMAT = 'G'). NEV is the number of | c | eigenvalues (closest to the shift SIGMA) to be | c | approximated. Since the shift and invert mode | c | is used, WHICH is set to 'LM'. The user can | c | modify NX, NEV and NCV to solve problems of | c | different sizes, and to get different parts the | c | spectrum. However, the following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = (1.0E+1, 0.0E+0) c c %----------------------------------------------------% c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL has to be set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine machine | c | precision is used. Setting INFO=0 indicates that | c | we using a randomly generated vector to start the | c | the ARNOLDI process. | c %----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv info = 0 tol = 0.0 c c %---------------------------------------------------% c | IPARAm(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of CNAUPD is used | c | (IPARAm(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in cnband. | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call claset('A', lda, n, zero, zero, a, lda) call claset('A', lda, n, zero, zero, m, lda) call claset('A', lda, n, zero, zero, fac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / cmplx(n+1) idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = four * h / six 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = (1.0E+1, 0.0E+0) do 40 j = 1, n-1 a(isup,j+1) = -one/h + rho/two a(isub,j) = -one/h - rho/two m(isup,j+1) = one*h / six m(isub,j) = one*h / six 40 continue c c %-----------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. Eigenvalues are returned in | c | the one dimensional array D. Eigenvectors | c | are returned in the first NCONV (=IPARAM(5)) | c | columns of V. | c %-----------------------------------------------% c rvec = .true. call cnband(rvec, 'A', select, d, v, ldv, sigma, & workev, n, a, m, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, '_NBDR4 ' print *, '====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c do 90 j = 1, nconv c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call cgbmv('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call caxpy(n, -d(j), mx, 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1), rd(j,2)) 90 continue call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for cnband. | c %-------------------------------------% c print *, ' ' print *, ' Error with _band, info= ', info print *, ' Check the documentation of _band ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/znbdr1.f0000644000175000017500000002510107174075122017770 0ustar andreasandreas program znbdr1 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-d convection-diffusion operator c c -Laplacian(u) + rho*partial(u)/partial(x). c c on the unit square with zero Dirichlet boundary condition c using standard central difference. c c ... Call ZNBAND to find eigenvalues LAMBDA such that c A*x = x*LAMBDA. c c ... Use mode 1 of ZNAUPD . c c\BeginLib c c znband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zlaset LAPACK routine to initialize a matrix to zero. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c dznrm2 Level 1 BLAS that computes the norm of a vector. c zgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr1.F SID: 2.3 DATE OF SID: 08/26/96 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Complex*16 & a(lda,maxn), m(lda,maxn), fac(lda,maxn), & workl(3*maxncv*maxncv+5*maxncv), workd(3*maxn), & workev(2*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv), ax(maxn) Double precision & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, kl, ku, info, i, j, & n, nx, lo, isub, isup, idiag, maxitr, mode, & nconv logical rvec Double precision & tol Complex*16 & rho, h, h2, sigma c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero, two parameter ( one = (1.0D+0, 0.0D+0) , & zero = (0.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external dznrm2 , zgbmv , zaxpy , dlapy2 , zlaset c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV and WHICH to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, the following | c | conditions must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' c c %-----------------------------------------------------% c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. Setting INFO=0 indicates that a | c | random vector is generated in ZNAUPD to start the | c | Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of ZNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details, see the documentation | c | in znband . | c %---------------------------------------------------% c maxitr = 300 mode = 1 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call zlaset ('A', lda, n, zero, zero, a, lda) call zlaset ('A', lda, n, zero, zero, m, lda) call zlaset ('A', lda, n, zero, zero, fac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nx ku = nx c c %---------------% c | Main diagonal | c %---------------% c h = one / dcmplx (nx+1) h2 = h*h c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = (4.0D+0, 0.0D+0) / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c rho = (1.0D+2, 0.0D+0) isup = kl+ku isub = kl+ku+2 do 50 i = 1, nx lo = (i-1)*nx do 40 j = lo+1, lo+nx-1 a(isup,j+1) = -one/h2 + rho/two/h a(isub,j) = -one/h2 - rho/two/h 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nx-1 lo = (i-1)*nx do 70 j = lo+1, lo+nx a(isup,nx+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %-----------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. Eigenvalues are returned in | c | the one dimensional array D. Eigenvectors | c | are returned in the first NCONV (=IPARAM(5)) | c | columns of V. | c %-----------------------------------------------% c rvec = .true. call znband (rvec, 'A', select, d, v, ldv, sigma, & workev, n, a, m, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, '_NBDR1 ' print *, '====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv c c %---------------------------% c | Compute the residual norm | c | || A*x - lambda*x || | c %---------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call zaxpy (n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1),rd(j,2)) 90 continue call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for znband . | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/znbdr2.f0000644000175000017500000002532307174076042020001 0ustar andreasandreas program znbdr2 c c ... Construct the matrix A in LAPACK-style band form. c The matrix A is derived from the discretization of c the 2-d convection-diffusion operator c c -Laplacian(u) + rho*partial(u)/partial(x). c c on the unit square with zero Dirichlet boundary condition c using standard central difference. c c ... Call ZNBAND to find eigenvalues LAMBDA such that c A*x = x*LAMBDA. c c ... Use mode 3 of ZNAUPD . c c\BeginLib c c znband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zlaset LAPACK routine to initialize a matrix to zero. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c dznrm2 Level 1 BLAS that computes the norm of a vector. c zgbmv Level 2 BLAS that computes the band matrix vector product c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr2.F SID: 2.4 DATE OF SID: 10/20/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c---------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Complex*16 & a(lda,maxn), m(lda,maxn), fac(lda,maxn), & workl(3*maxncv*maxncv+5*maxncv), workd(3*maxn), & workev(2*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv), ax(maxn) Double precision & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, kl, ku, info, i, j, & n, nxi, lo, isub, isup, idiag, maxitr, mode, & nconv logical rvec Double precision & tol Complex*16 & rho, h, h2, sigma c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero, two parameter (one = (1.0D+0, 0.0D+0) , & zero = (0.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external dznrm2 , zgbmv , zaxpy , dlapy2 , zlaset c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues (closest to SIGMA) to be | c | approximated. Since the shift and invert mode | c | is used, WHICH is set to 'LM'. The user can | c | modify NX, NEV and NCV to solve problems of | c | different sizes, and to get different parts the | c | spectrum. However, the following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c nxi = 10 n = nxi*nxi nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigma = zero c c %-----------------------------------------------------% c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. Setting INFO=0 indicates that a | c | random vector is generated in ZNAUPD to start the | c | Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 info = 0 c c %---------------------------------------------------% c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of ZNAUPD is used | c | (IPARAM(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in znband . | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %----------------------------------------% c | Construct the matrix A in LAPACK-style | c | banded form. | c %----------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call zlaset ('A', lda, n, zero, zero, a, lda) call zlaset ('A', lda, n, zero, zero, m, lda) call zlaset ('A', lda, n, zero, zero, fac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = nxi ku = nxi c c %---------------% c | Main diagonal | c %---------------% c h = one / dcmplx (nxi+1) h2 = h*h c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = (4.0D+0, 0.0D+0) / h2 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c rho = (1.0D+2, 0.0D+0) isup = kl+ku isub = kl+ku+2 do 50 i = 1, nxi lo = (i-1)*nxi do 40 j = lo+1, lo+nxi-1 a(isup,j+1) = -one/h2 + rho/two/h a(isub,j) = -one/h2 - rho/two/h 40 continue 50 continue c c %------------------------------------% c | KL-th subdiagonal and KU-th super- | c | diagonal. | c %------------------------------------% c isup = kl+1 isub = 2*kl+ku+1 do 80 i = 1, nxi-1 lo = (i-1)*nxi do 70 j = lo+1, lo+nxi a(isup,nxi+j) = -one / h2 a(isub,j) = -one / h2 70 continue 80 continue c c %-----------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. Eigenvalues are returned in | c | the one dimensional array D. Eigenvectors | c | are returned in the first NCONV (=IPARAM(5)) | c | columns of V. | c %-----------------------------------------------% c rvec = .true. call znband (rvec, 'A', select, d, v, ldv, sigma, & workev, n, a, m, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, '_NBDR2 ' print *, '====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c do 90 j = 1, nconv c c %---------------------------% c | Compute the residual norm | c | || A*x - lambda*x || | c %---------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call zaxpy (n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1),rd(j,2)) 90 continue call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for znband . | c %-------------------------------------% c print *, ' ' print *, ' Error with _nband, info= ', info print *, ' Check the documentation of _nband ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/znbdr3.f0000644000175000017500000002441107174076046020003 0ustar andreasandreas program znbdr3 c c ... Construct matrices A and M in LAPACK-style band form. c Matrices A and M are derived from the finite c element discretization of the 1-dimensional c convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition using c piecewise linear elements. c c ... Call ZNBAND to find eigenvalues LAMBDA such that c A*x = M*x*LAMBDA. c c ... Eigenvalues with largest real parts are sought. c c ... Use mode 2 of ZNAUPD . c c\BeginLib c c\Routines called: c znband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zlaset LAPACK routine to initialize a matrix to zero. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c dznrm2 Level 1 BLAS that computes the norm of a vector. c zgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr3.F SID: 2.4 DATE OF SID: 10/20/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c------------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Complex*16 & a(lda,maxn), m(lda,maxn), fac(lda,maxn), & workl(3*maxncv*maxncv+5*maxncv), workd(3*maxn), & workev(2*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv), ax(maxn), mx(maxn) Double precision & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, & n, idiag, isup, isub, maxitr, & mode, nconv logical rvec Double precision & tol Complex*16 & rho, h, sigma c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero, two parameter (one = (1.0D+0, 0.0D+0) , & zero = (0.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external dznrm2 , zgbmv , zaxpy , dlapy2 , zlaset c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A generalized eigenvalue problem is | c | solved (BMAT = 'G'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV and WHICH to solve problems | c | of different sizes, and to get different parts | c | the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = zero c c %----------------------------------------------------% c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL has to be set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine machine | c | precision is used. Setting INFO=0 indicates that | c | using a randomly generated vector to start the | c | the ARNOLDI process. | c %----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv info = 0 tol = 0.0 c c %---------------------------------------------------% c | IPARAm(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of ZNAUPD is used | c | (IPARAm(7) = 2). All these options can be changed | c | by the user. For details, see the documentation | c | in znband . | c %---------------------------------------------------% c maxitr = 300 mode = 2 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call zlaset ('A', lda, n, zero, zero, a, lda) call zlaset ('A', lda, n, zero, zero, m, lda) call zlaset ('A', lda, n, zero, zero, fac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / dcmplx (n+1) c idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = (2.0D+0, 0.0D+0) / h m(idiag,j) = (4.0D+0, 0.0D+0) * h 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = (1.0D+1, 0.0D+0) do 40 j = 1, n-1 a(isup,j+1) = -one/h + rho/two a(isub,j) = -one/h - rho/two m(isup,j+1) = one*h m(isub,j) = one*h 40 continue c c %-----------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. Eigenvalues are returned in | c | the one dimensional array D. Eigenvectors | c | are returned in the first NCONV (=IPARAM(5)) | c | columns of V. | c %-----------------------------------------------% c rvec = .true. call znband (rvec, 'A', select, d, v, ldv, sigma, & workev, n, a, m, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, '_NBDR3 ' print *, '====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c do 50 j = 1, nconv c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call zgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call zaxpy (n, -d(j), mx, 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1), rd(j,2)) 50 continue call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for znband . | c %-------------------------------------% c print *, ' ' print *, ' Error with _band, info= ', info print *, ' Check the documentation of _band ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/znbdr4.f0000644000175000017500000002462707174077530020014 0ustar andreasandreas program zndrv4 c c ... Construct matrices A and M in LAPACK-style band form. c Matries A and M are derived from the finite c element discretization of the 1-dimensional c convection-diffusion operator c (d^2u/dx^2) + rho*(du/dx) c on the interval [0,1] with zero boundary condition using c piecewise linear elements. c c ... Call ZNBAND to find eigenvalues LAMBDA such that c A*x = M*x*LAMBDA. c c ... Use mode 3 of ZNAUPD . c c\BeginLib c c\Routines called: c znband ARPACK banded eigenproblem solver. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c zlaset LAPACK routine to initialize a matrix to zero. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c dznrm2 Level 1 BLAS that computes the norm of a vector. c zgbmv Level 2 BLAS that computes the band matrix vector product. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nbdr4.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c------------------------------------------------------------------------- c c %-------------------------------------% c | Define leading dimensions for all | c | arrays. | c | MAXN - Maximum size of the matrix | c | MAXNEV - Maximum number of | c | eigenvalues to be computed | c | MAXNCV - Maximum number of Arnoldi | c | vectors stored | c | MAXBDW - Maximum bandwidth | c %-------------------------------------% c integer maxn, maxnev, maxncv, maxbdw, lda, & lworkl, ldv parameter ( maxn = 1000, maxnev = 25, maxncv=50, & maxbdw=50, lda = maxbdw, ldv = maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), iwork(maxn) logical select(maxncv) Complex*16 & a(lda,maxn), m(lda,maxn), fac(lda,maxn), & workl(3*maxncv*maxncv+5*maxncv), workd(3*maxn), & workev(2*maxncv), v(ldv, maxncv), & resid(maxn), d(maxncv), ax(maxn), mx(maxn) Double precision & rwork(maxn), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character which*2, bmat integer nev, ncv, ku, kl, info, j, & n, idiag, isup, isub, maxitr, mode, & nconv logical rvec Double precision & tol Complex*16 & rho, h, sigma c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero, two, four, six parameter (one = (1.0D+0, 0.0D+0) , & zero = (0.0D+0, 0.0D+0) , & two = (2.0D+0, 0.0D+0) , & four = (4.0D+0, 0.0D+0) , & six = (6.0D+0, 0.0D+0) ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external dznrm2 , zgbmv , zaxpy , dlapy2 , zlaset c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A generalized eigenvalue problem is | c | solved (BMAT = 'G'). NEV is the number of | c | eigenvalues (closest to the shift SIGMA) to be | c | approximated. Since the shift and invert mode | c | is used, WHICH is set to 'LM'. The user can | c | modify NX, NEV and NCV to solve problems of | c | different sizes, and to get different parts the | c | spectrum. However, the following conditions | c | must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %-------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NBDR4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NBDR4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NBDR4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = (1.0D+1, 0.0D+0) c c %----------------------------------------------------% c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL has to be set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine machine | c | precision is used. Setting INFO=0 indicates that | c | we using a randomly generated vector to start the | c | the ARNOLDI process. | c %----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv info = 0 tol = 0.0 c c %---------------------------------------------------% c | IPARAm(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of ZNAUPD is used | c | (IPARAm(7) = 3). All these options can be changed | c | by the user. For details, see the documentation | c | in znband . | c %---------------------------------------------------% c maxitr = 300 mode = 3 c iparam(3) = maxitr iparam(7) = mode c c %--------------------------------------------% c | Construct matrices A and M in LAPACK-style | c | banded form. | c %--------------------------------------------% c c %---------------------------------------------% c | Zero out the workspace for banded matrices. | c %---------------------------------------------% c call zlaset ('A', lda, n, zero, zero, a, lda) call zlaset ('A', lda, n, zero, zero, m, lda) call zlaset ('A', lda, n, zero, zero, fac, lda) c c %-------------------------------------% c | KU, KL are number of superdiagonals | c | and subdiagonals within the band of | c | matrices A and M. | c %-------------------------------------% c kl = 1 ku = 1 c c %---------------% c | Main diagonal | c %---------------% c h = one / dcmplx (n+1) idiag = kl+ku+1 do 30 j = 1, n a(idiag,j) = two / h m(idiag,j) = four * h / six 30 continue c c %-------------------------------------% c | First subdiagonal and superdiagonal | c %-------------------------------------% c isup = kl+ku isub = kl+ku+2 rho = (1.0D+1, 0.0D+0) do 40 j = 1, n-1 a(isup,j+1) = -one/h + rho/two a(isub,j) = -one/h - rho/two m(isup,j+1) = one*h / six m(isub,j) = one*h / six 40 continue c c %-----------------------------------------------% c | Call ARPACK banded solver to find eigenvalues | c | and eigenvectors. Eigenvalues are returned in | c | the one dimensional array D. Eigenvectors | c | are returned in the first NCONV (=IPARAM(5)) | c | columns of V. | c %-----------------------------------------------% c rvec = .true. call znband (rvec, 'A', select, d, v, ldv, sigma, & workev, n, a, m, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info) c if ( info .eq. 0) then c nconv = iparam(5) c c %-----------------------------------% c | Print out convergence information | c %-----------------------------------% c print *, ' ' print *, '_NBDR4 ' print *, '====== ' print *, ' ' print *, ' The size of the matrix is ', n print *, ' Number of eigenvalue requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' The number of converged Ritz values is ', & nconv print *, ' What portion of the spectrum ', which print *, ' The number of Implicit Arnoldi ', & ' update taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence tolerance is ', tol print *, ' ' c do 90 j = 1, nconv c c %----------------------------% c | Compute the residual norm. | c | || A*x - lambda*x || | c %----------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, & a(kl+1,1), lda, v(1,j), 1, zero, & ax, 1) call zgbmv ('Notranspose', n, n, kl, ku, one, & m(kl+1,1), lda, v(1,j), 1, zero, & mx, 1) call zaxpy (n, -d(j), mx, 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1), rd(j,2)) 90 continue call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') else c c %-------------------------------------% c | Either convergence failed, or there | c | is error. Check the documentation | c | for znband . | c %-------------------------------------% c print *, ' ' print *, ' Error with _band, info= ', info print *, ' Check the documentation of _band ' print *, ' ' c end if c 9000 end arpack-akloeckner-07/EXAMPLES/BAND/cnband.f0000644000175000017500000005507007172777701020037 0ustar andreasandreasc \BeginDoc c c \Name: cnband c c \Description: c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c Matrices A and B are stored in LAPACK-style banded form. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are commonly called Ritz values and Ritz vectors respectively. They are c referred to as such in the comments that follow. The computed orthonormal c basis for the invariant subspace corresponding to these Ritz values is c referred to as a Schur basis. c c cnband can be called with one of the following modes: c c Mode 1: A*z = lambda*z. c ===> OP = A and B = I. c c Mode 2: A*z = lambda*M*z, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c c Mode 3: A*z = lambda*M*z, M symmetric semi-definite c ===> OP = inv[A - sigma*M]*M and B = M. c ===> shift-and-invert mode. c c Choice of different modes can be specified in IPARAM(7) defined below. c c \Usage c call cnband c ( RVEC, HOWMNY, SELECT, D , Z, LDZ, SIGMA, WORKEV, N, AB, c MB, LDA, FAC, KL, KU, WHICH, BMAT, NEV, TOL, RESID, NCV, c V, LDV, IPARAM, WORKD, WORKL, LWORKL, RWORK, IWORK, INFO ) c c \Arguments c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the invariant subspace to be computed c corresponding to the converged Ritz values. c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the real Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT need not be initialized c but it is used as internal workspace. c c D Complex array of dimension NEV+1. (OUTPUT) c On exit, D contains the Ritz approximations c to the eigenvalues lambda for A*z = lambda*B*z. c c Z Complex N by NEV array (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represents approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV columns of the c array V. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ) is required. c In any case, LDZ .ge. 1 is required. c c SIGMA Complex (INPUT) c If IPARAM(7) = 3 then SIGMA represents the shift. c Not referenced if IPARAM(7) = 1 or 2. c c WORKEV Complex work array of dimension NCV. (WORKSPACE) c c N Integer. (INPUT) c Dimension of the eigenproblem. c c AB Complex array of dimension LDA by N. (INPUT) c The matrix A in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of A is stored in the j-th column of the c array AB as follows: c AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c c MB Complex array of dimension LDA by N. (INPUT) c The matrix M in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of M is stored in the j-th column of the c array MB as follows: c MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c Not referenced if IPARAM(7)=1. c c LDA Integer. (INPUT) c Leading dimension of AB, MB, FAC. c c FAC Complex array of LDA by N. (WORKSPACE/OUTPUT) c FAC is used to store the LU factors of MB when mode 2 c is invoked. It is used to store the LU factors of c (A-sigma*M) when mode 3 is invoked. c It is not referenced when IPARAM(7)=1. c c KL Integer. (INPUT) c Max(number of subdiagonals of A, number of subdiagonals of M) c c KU Integer. (OUTPUT) c Max(number of superdiagonals of A, number of superdiagonals of M) c c WHICH Character*2. (INPUT) c When mode 1,2 are used, WHICH can be set to any one of c the following. c c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c When mode 3 is used, WHICH should be set to 'LM' only. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c NEV Integer. (INPUT) c Number of eigenvalues of to be computed. c c TOL Real scalar. (INPUT) c Stopping criteria: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = slamch('EPS') (machine precision as computed c by the LAPACK auxilliary subroutine slamch). c c RESID Complex array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 2 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. c c V Complex array N by NCV. (OUTPUT) c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then c the first NCONV=IPARAM(5) columns of V will contain Ritz vectors c of the eigensystem A*z = lambda*B*z. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. LDV must be great than or equal to N. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c It is set to 1 in this subroutine. The user do not need c to set this parameter. c ---------------------------------------------------------- c ISHIFT = 1: exact shift with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration from the beginning c after updating the starting vector with a linear c combination of Ritz vectors associated with the c "wanted" eigenvalues. c ------------------------------------------------------------- c c IPARAM(2) = Not referenced. c c IPARAM(3) = MXITER c On INPUT: max number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" eigenvalues. c c IPARAM(6) = IUPD c Not referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2 or 3; See under \Description of cnband for the c three modes available. c c WORKD Complex work array of length at least 3*n. (WORKSPACE) c c WORKL Complex work array of length LWORKL. (WORKSPACE) c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 5*NCV. c c RWORK Real array of length N (WORKSPACE) c Workspace used in cnaupd. c c IWORK Integer array of dimension at least N. (WORKSPACE) c Used to mode 2,3. Store the pivot information in the c factorization of M or (A-SIGMA*M). c c INFO Integer. (INPUT/OUTPUT) c Error flag on output. c = 0: Normal exit. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation. c This should never happened. c = -10: IPARAM(7) must be 1,2,3. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: CNAUPD did not find any eigenvalues to sufficient c accuracy. c c \EndDoc c c------------------------------------------------------------------------ c c\BeginLib c c\Routines called c cnaupd ARPACK reverse communication interface routine. c cneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c cgbtrf LAPACK band matrix factorization routine. c cgbtrs LAPACK band linear system solve routine. c clacpy LAPACK matrix copy routine. c ccopy Level 1 BLAS that copies one vector to another. c scnrm2 Level 1 BLAS that computes the norm of a vector. c cgbmv Level 2 BLAS that computes the band matrix vector product. c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ, c May 1995. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nband.F SID: 2.3 DATE OF SID: 10/17/00 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine cnband(rvec, howmny, select, d , z, ldz, sigma, & workev, n, ab, mb, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info ) c c %------------------% c | Scalar Arguments | c %------------------% c Character which*2, bmat, howmny Logical rvec Integer n, lda, kl, ku, nev, ncv, ldv, & ldz, lworkl, info Complex & sigma Real & tol c c %-----------------% c | Array Arguments | c %-----------------% c Integer iparam(*), iwork(*) Logical select(*) Complex & d(*), resid(*), v(ldv,*), z(ldz,*), & ab(lda,*), mb(lda,*), fac(lda,*), & workd(*), workl(*), workev(*) Real & rwork(*) c c %--------------% c | Local Arrays | c %--------------% c integer ipntr(14) c c %---------------% c | Local Scalars | c %---------------% c integer ido, i, j, mode, ierr, itop, imid, ibot c c %------------% c | Parameters | c %------------% c Complex & one, zero parameter (one = (1.0E+0, 0.0E+0) , & zero = (0.0E+0, 0.0E+0) ) c c %-----------------------------% c | LAPACK & BLAS routines used | c %-----------------------------% c Real & scnrm2 external ccopy, cgbmv, cgbtrf, cgbtrs, scnrm2, clacpy c c %-----------------------% c | Executable Statements | c %-----------------------% c mode = iparam(7) c c %------------------------% c | Initialize the reverse | c | communication flag. | c %------------------------% c ido = 0 c c %----------------% c | Exact shift is | c | used. | c %----------------% c iparam(1) = 1 c c %-----------------------------------% c | Both matrices A and M are stored | c | between rows itop and ibot. Imid | c | is the index of the row that | c | stores the diagonal elements. | c %-----------------------------------% c itop = kl + 1 imid = kl + ku + 1 ibot = 2*kl + ku + 1 c if ( mode .eq. 2 ) then c c %-----------------------------------------------% c | Copy M to fac and Call LAPACK routine cgbtrf | c | to factor M. | c %-----------------------------------------------% c call clacpy ('A', ibot, n, mb, lda, fac, lda ) call cgbtrf(n, n, kl, ku, fac, lda, iwork, ierr) if (ierr .ne. 0) then print*, ' ' print*,'_band: error in _gbtrf' print*, ' ' go to 9000 end if c else if ( mode .eq. 3 ) then c if (bmat .eq. 'I') then c c %-------------------------% c | Construct (A - sigma*I) | c %-------------------------% c call clacpy ('A', ibot, n, ab, lda, fac, lda ) do 10 j = 1,n fac(imid,j) = ab(imid,j) - sigma 10 continue c else c c %---------------------------% c | Construct (A - sigma*M) | c %---------------------------% c do 30 j = 1,n do 20 i = itop, ibot fac(i,j) = ab(i,j) - sigma*mb(i,j) 20 continue 30 continue c end if c c %------------------------% c | Factor (A - sigma*M) | c %------------------------% c call cgbtrf(n, n, kl, ku, fac, lda, iwork, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_band: error in _gbtrf.' print*, ' ' go to 9000 end if c end if c c %--------------------------------------------% c | M A I N L O O P (reverse communication) | c %--------------------------------------------% c 40 continue c call cnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork,info ) c if (ido .eq. -1) then c if ( mode .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( mode .eq. 2 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c %-----------------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in sbgtrs.' print*, ' ' go to 9000 end if c else if ( mode .eq. 3 ) then c c %-----------------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*M* x c | to force the starting vector into the | c | range of OP. | c %-----------------------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in _gbtrs.' print*, ' ' go to 9000 end if c end if c else if (ido .eq. 1) then c if ( mode .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( mode .eq. 2 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c %-----------------------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), ldv, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in sbgtrs.' print*, ' ' go to 9000 end if c else if ( mode .eq. 3 ) then c if ( bmat .eq. 'I' ) then c c %----------------------------------% c | Perform y <-- inv(A-sigma*I)*x. | c %----------------------------------% c call ccopy(n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in _gbtrs.' print*, ' ' go to 9000 end if c else c c %--------------------------------------% c | Perform y <-- inv(A-sigma*M)*(M*x). | c | (M*x) has been computed and stored | c | in workd(ipntr(3)). | c %--------------------------------------% c call ccopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call cgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in _gbtrs.' print*, ' ' go to 9000 end if c end if c endif c else if (ido .eq. 2) then c c %--------------------% c | Perform y <-- M*x | c %--------------------% c call cgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else c c %-------------------------------------------% c | Either we have convergence, or there is | c | error. | c %-------------------------------------------% c if ( info .ne. 0) then c c %--------------------------% c | Error message, check the | c | documentation in dnaupd | c %--------------------------% c print *, ' ' print *, ' Error with _naupd info = ',info print *, ' Check the documentation of _naupd ' print *, ' ' c else c call cneupd (rvec, howmny , select, d, z, ldz, sigma, & workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, rwork, info) c if ( info .ne. 0) then c c %------------------------------------% c | Check the documentation of cneupd. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd = ', info print *, ' Check the documentation of _neupd ' print *, ' ' c endif c end if c go to 9000 c end if c c %----------------------------------------% c | L O O P B A C K to call cnaupd again. | c %----------------------------------------% c go to 40 c 9000 continue c end arpack-akloeckner-07/EXAMPLES/BAND/znband.f0000644000175000017500000005531407172777701020067 0ustar andreasandreasc \BeginDoc c c \Name: znband c c \Description: c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c Matrices A and B are stored in LAPACK-style banded form. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are commonly called Ritz values and Ritz vectors respectively. They are c referred to as such in the comments that follow. The computed orthonormal c basis for the invariant subspace corresponding to these Ritz values is c referred to as a Schur basis. c c znband can be called with one of the following modes: c c Mode 1: A*z = lambda*z. c ===> OP = A and B = I. c c Mode 2: A*z = lambda*M*z, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c c Mode 3: A*z = lambda*M*z, M symmetric semi-definite c ===> OP = inv[A - sigma*M]*M and B = M. c ===> shift-and-invert mode. c c Choice of different modes can be specified in IPARAM(7) defined below. c c \Usage c call znband c ( RVEC, HOWMNY, SELECT, D , Z, LDZ, SIGMA, WORKEV, N, AB, c MB, LDA, FAC, KL, KU, WHICH, BMAT, NEV, TOL, RESID, NCV, c V, LDV, IPARAM, WORKD, WORKL, LWORKL, RWORK, IWORK, INFO ) c c \Arguments c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the invariant subspace to be computed c corresponding to the converged Ritz values. c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the real Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT need not be initialized c but it is used as internal workspace. c c D Complex*16 array of dimension NEV+1. (OUTPUT) c On exit, D contains the Ritz approximations c to the eigenvalues lambda for A*z = lambda*B*z. c c Z Complex*16 N by NEV array (OUTPUT) c On exit, if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represents approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is NOT REFERENCED. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV columns of the c array V. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ) is required. c In any case, LDZ .ge. 1 is required. c c SIGMA Complex*16 (INPUT) c If IPARAM(7) = 3 then SIGMA represents the shift. c Not referenced if IPARAM(7) = 1 or 2. c c WORKEV Complex*16 work array of dimension NCV. (WORKSPACE) c c N Integer. (INPUT) c Dimension of the eigenproblem. c c AB Complex*16 array of dimension LDA by N. (INPUT) c The matrix A in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of A is stored in the j-th column of the c array AB as follows: c AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c c MB Complex*16 array of dimension LDA by N. (INPUT) c The matrix M in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of M is stored in the j-th column of the c array MB as follows: c MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c Not referenced if IPARAM(7)=1. c c LDA Integer. (INPUT) c Leading dimension of AB, MB, FAC. c c FAC Complex*16 array of LDA by N. (WORKSPACE/OUTPUT) c FAC is used to store the LU factors of MB when mode 2 c is invoked. It is used to store the LU factors of c (A-sigma*M) when mode 3 is invoked. c It is not referenced when IPARAM(7)=1. c c KL Integer. (INPUT) c Max(number of subdiagonals of A, number of subdiagonals of M) c c KU Integer. (OUTPUT) c Max(number of superdiagonals of A, number of superdiagonals of M) c c WHICH Character*2. (INPUT) c When mode 1,2 are used, WHICH can be set to any one of c the following. c c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c When mode 3 is used, WHICH should be set to 'LM' only. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c NEV Integer. (INPUT) c Number of eigenvalues of to be computed. c c TOL Double precision scalar. (INPUT) c Stopping criteria: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)) c where ABS(RITZ(I)) is the magnitude when RITZ(I) is complex. c DEFAULT = dlamch ('EPS') (machine precision as computed c by the LAPACK auxilliary subroutine dlamch ). c c RESID Complex*16 array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V. NCV must satisfy the two c inequalities 2 <= NCV-NEV and NCV <= N. c This will indicate how many Arnoldi vectors are generated c at each iteration. After the startup phase in which NEV c Arnoldi vectors are generated, the algorithm generates c approximately NCV-NEV Arnoldi vectors at each subsequent update c iteration. Most of the cost in generating each Arnoldi vector is c in the matrix-vector operation OP*x. c c V Complex*16 array N by NCV. (OUTPUT) c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c contain approximate Schur vectors that span the c desired invariant subspace. c c NOTE: If the array Z has been set equal to first NEV+1 columns c of the array V and RVEC=.TRUE. and HOWMNY= 'A', then c the first NCONV=IPARAM(5) columns of V will contain Ritz vectors c of the eigensystem A*z = lambda*B*z. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. LDV must be great than or equal to N. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c It is set to 1 in this subroutine. The user do not need c to set this parameter. c ---------------------------------------------------------- c ISHIFT = 1: exact shift with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration from the beginning c after updating the starting vector with a linear c combination of Ritz vectors associated with the c "wanted" eigenvalues. c ------------------------------------------------------------- c c IPARAM(2) = Not referenced. c c IPARAM(3) = MXITER c On INPUT: max number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" eigenvalues. c c IPARAM(6) = IUPD c Not referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2 or 3; See under \Description of znband for the c three modes available. c c WORKD Complex*16 work array of length at least 3*n. (WORKSPACE) c c WORKL Complex*16 work array of length LWORKL. (WORKSPACE) c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 5*NCV. c c RWORK Double precision array of length N (WORKSPACE) c Workspace used in znaupd . c c IWORK Integer array of dimension at least N. (WORKSPACE) c Used to mode 2,3. Store the pivot information in the c factorization of M or (A-SIGMA*M). c c INFO Integer. (INPUT/OUTPUT) c Error flag on output. c = 0: Normal exit. c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from LAPACK eigenvalue calculation. c This should never happened. c = -10: IPARAM(7) must be 1,2,3. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' if RVEC = .true. c = -14: ZNAUPD did not find any eigenvalues to sufficient c accuracy. c c \EndDoc c c------------------------------------------------------------------------ c c\BeginLib c c\Routines called c znaupd ARPACK reverse communication interface routine. c zneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c zgbtrf LAPACK band matrix factorization routine. c zgbtrs LAPACK band linear system solve routine. c zlacpy LAPACK matrix copy routine. c zcopy Level 1 BLAS that copies one vector to another. c dznrm2 Level 1 BLAS that computes the norm of a vector. c zgbmv Level 2 BLAS that computes the band matrix vector product. c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ, c May 1995. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nband.F SID: 2.3 DATE OF SID: 10/17/00 RELEASE: 2 c c\EndLib c c----------------------------------------------------------------------- c subroutine znband (rvec, howmny, select, d , z, ldz, sigma, & workev, n, ab, mb, lda, fac, kl, ku, which, & bmat, nev, tol, resid, ncv, v, ldv, iparam, & workd, workl, lworkl, rwork, iwork, info ) c c %------------------% c | Scalar Arguments | c %------------------% c Character which*2, bmat, howmny Logical rvec Integer n, lda, kl, ku, nev, ncv, ldv, & ldz, lworkl, info Complex*16 & sigma Double precision & tol c c %-----------------% c | Array Arguments | c %-----------------% c Integer iparam(*), iwork(*) Logical select(*) Complex*16 & d(*), resid(*), v(ldv,*), z(ldz,*), & ab(lda,*), mb(lda,*), fac(lda,*), & workd(*), workl(*), workev(*) Double precision & rwork(*) c c %--------------% c | Local Arrays | c %--------------% c integer ipntr(14) c c %---------------% c | Local Scalars | c %---------------% c integer ido, i, j, mode, ierr, itop, imid, ibot c c %------------% c | Parameters | c %------------% c Complex*16 & one, zero parameter (one = (1.0D+0, 0.0D+0) , & zero = (0.0D+0, 0.0D+0) ) c c %-----------------------------% c | LAPACK & BLAS routines used | c %-----------------------------% c Double precision & dznrm2 external zcopy , zgbmv , zgbtrf , zgbtrs , dznrm2 , zlacpy c c %-----------------------% c | Executable Statements | c %-----------------------% c mode = iparam(7) c c %------------------------% c | Initialize the reverse | c | communication flag. | c %------------------------% c ido = 0 c c %----------------% c | Exact shift is | c | used. | c %----------------% c iparam(1) = 1 c c %-----------------------------------% c | Both matrices A and M are stored | c | between rows itop and ibot. Imid | c | is the index of the row that | c | stores the diagonal elements. | c %-----------------------------------% c itop = kl + 1 imid = kl + ku + 1 ibot = 2*kl + ku + 1 c if ( mode .eq. 2 ) then c c %-----------------------------------------------% c | Copy M to fac and Call LAPACK routine zgbtrf | c | to factor M. | c %-----------------------------------------------% c call zlacpy ('A', ibot, n, mb, lda, fac, lda ) call zgbtrf (n, n, kl, ku, fac, lda, iwork, ierr) if (ierr .ne. 0) then print*, ' ' print*,'_band: error in _gbtrf' print*, ' ' go to 9000 end if c else if ( mode .eq. 3 ) then c if (bmat .eq. 'I') then c c %-------------------------% c | Construct (A - sigma*I) | c %-------------------------% c call zlacpy ('A', ibot, n, ab, lda, fac, lda ) do 10 j = 1,n fac(imid,j) = ab(imid,j) - sigma 10 continue c else c c %---------------------------% c | Construct (A - sigma*M) | c %---------------------------% c do 30 j = 1,n do 20 i = itop, ibot fac(i,j) = ab(i,j) - sigma*mb(i,j) 20 continue 30 continue c end if c c %------------------------% c | Factor (A - sigma*M) | c %------------------------% c call zgbtrf (n, n, kl, ku, fac, lda, iwork, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_band: error in _gbtrf.' print*, ' ' go to 9000 end if c end if c c %--------------------------------------------% c | M A I N L O O P (reverse communication) | c %--------------------------------------------% c 40 continue c call znaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork,info ) c if (ido .eq. -1) then c if ( mode .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( mode .eq. 2 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c %-----------------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call zgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in sbgtrs.' print*, ' ' go to 9000 end if c else if ( mode .eq. 3 ) then c c %-----------------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*M* x c | to force the starting vector into the | c | range of OP. | c %-----------------------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call zgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in _gbtrs.' print*, ' ' go to 9000 end if c end if c else if (ido .eq. 1) then c if ( mode .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( mode .eq. 2 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c %-----------------------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call zgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), ldv, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in sbgtrs.' print*, ' ' go to 9000 end if c else if ( mode .eq. 3 ) then c if ( bmat .eq. 'I' ) then c c %----------------------------------% c | Perform y <-- inv(A-sigma*I)*x. | c %----------------------------------% c call zcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call zgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in _gbtrs.' print*, ' ' go to 9000 end if c else c c %--------------------------------------% c | Perform y <-- inv(A-sigma*M)*(M*x). | c | (M*x) has been computed and stored | c | in workd(ipntr(3)). | c %--------------------------------------% c call zcopy (n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call zgbtrs ('Notranspose', n, kl, ku, 1, fac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_band: error in _gbtrs.' print*, ' ' go to 9000 end if c end if c endif c else if (ido .eq. 2) then c c %--------------------% c | Perform y <-- M*x | c %--------------------% c call zgbmv ('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else c c %-------------------------------------------% c | Either we have convergence, or there is | c | error. | c %-------------------------------------------% c if ( info .ne. 0) then c c %--------------------------% c | Error message, check the | c | documentation in dnaupd | c %--------------------------% c print *, ' ' print *, ' Error with _naupd info = ',info print *, ' Check the documentation of _naupd ' print *, ' ' c else c call zneupd (rvec, howmny , select, d, z, ldz, sigma, & workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, rwork, info) c if ( info .ne. 0) then c c %------------------------------------% c | Check the documentation of zneupd . | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd = ', info print *, ' Check the documentation of _neupd ' print *, ' ' c endif c end if c go to 9000 c end if c c %----------------------------------------% c | L O O P B A C K to call znaupd again. | c %----------------------------------------% c go to 40 c 9000 continue c end arpack-akloeckner-07/EXAMPLES/BAND/dsband.f0000644000175000017500000007716207172773061020046 0ustar andreasandreasc \BeginDoc c c \Name: dsband c c \Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal (Lanczos) basis for the associated approximate c invariant subspace; c c (3) Both. c c Matrices A and B are stored in LAPACK-style band form. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c (Lanczos) basis is always computed. There is an additional storage cost c of n*nev if both are requested (in this case a separate array Z must be c supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are called Ritz values and Ritz vectors respectively. They are referred c to as such in the comments that follow. The computed orthonormal basis c for the invariant subspace corresponding to these Ritz values is referred c to as a Lanczos basis. c c dsband can be called with one of the following modes: c c Mode 1: A*x = lambda*x, A symmetric c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 in DSAUPD) c c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite c ===> OP = (inv[K - sigma*M])*M and B = M. c ===> Shift-and-Invert mode c c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, c KG symmetric indefinite c ===> OP = (inv[K - sigma*KG])*K and B = K. c ===> Buckling mode c c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. c ===> Cayley transformed mode c c The choice of mode must be specified in IPARAM(7) defined below. c c \Usage c call dsband c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, N, AB, MB, LDA, c RFAC, KL, KU, WHICH, BMAT, NEV, TOL, RESID, NCV, V, c LDV, IPARAM, WORKD, WORKL, LWORKL, IWORK, INFO ) c c \Arguments c c RVEC Logical (INPUT) c Specifies whether Ritz vectors corresponding to the Ritz value c approximations to the eigenproblem A*z = lambda*B*z are computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute the associated Ritz vectors. c c HOWMNY Character*1 (INPUT) c Specifies how many Ritz vectors are wanted and the form of Z c the matrix of Ritz vectors. See remark 1 below. c = 'A': compute all Ritz vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' , SELECT is not referenced. c c D Double precision array of dimension NEV. (OUTPUT) c On exit, D contains the Ritz value approximations to the c eigenvalues of A*z = lambda*B*z. The values are returned c in ascending order. If IPARAM(7) = 3,4,5 then D represents c the Ritz values of OP computed by dsaupd transformed to c those of the original eigensystem A*z = lambda*B*z. If c IPARAM(7) = 1,2 then the Ritz values of OP are the same c as the those of A*z = lambda*B*z. c c Z Double precision N by NEV array if HOWMNY = 'A'. (OUTPUT) c On exit, Z contains the B-orthonormal Ritz vectors of the c eigensystem A*z = lambda*B*z corresponding to the Ritz c value approximations. c c If RVEC = .FALSE. then Z is not referenced. c NOTE: The array Z may be set equal to first NEV columns of the c Lanczos basis array V computed by DSAUPD. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. c c SIGMA Double precision (INPUT) c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if c IPARAM(7) = 1 or 2. c c N Integer. (INPUT) c Dimension of the eigenproblem. c c AB Double precision array of dimension LDA by N. (INPUT) c The matrix A in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of A is stored in the j-th column of the c array AB as follows: c AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c c MB Double precision array of dimension LDA by N. (INPUT) c The matrix M in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of M is stored in the j-th column of the c array AB as follows: c MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c Not referenced if IPARAM(7) = 1 c c LDA Integer. (INPUT) c Leading dimension of AB, MB, RFAC. c c RFAC Double precision array of LDA by N. (WORKSPACE/OUTPUT) c RFAC is used to store the LU factors of MB when IPARAM(7) = 2 c is invoked. It is used to store the LU factors of c (A-sigma*M) when IPARAM(7) = 3,4,5 is invoked. c It is not referenced when IPARAM(7) = 1. c c KL Integer. (INPUT) c Max(number of subdiagonals of A, number of subdiagonals of M) c c KU Integer. (OUTPUT) c Max(number of superdiagonals of A, number of superdiagonals of M) c c WHICH Character*2. (INPUT) c When IPARAM(7)= 1 or 2, WHICH can be set to any one of c the following. c c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LA' -> want the NEV eigenvalues of largest REAL part. c 'SA' -> want the NEV eigenvalues of smallest REAL part. c 'BE' -> Compute NEV eigenvalues, half from each end of the c spectrum. When NEV is odd, compute one more from c the high end than from the low end. c c When IPARAM(7) = 3, 4, or 5, WHICH should be set to 'LM' only. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. c c TOL Double precision scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). c If TOL .LE. 0. is passed a default is set: c DEFAULT = DLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine DLAMCH). c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V (less than or equal to N). c Represents the dimension of the Lanczos basis constructed c by dsaupd for OP. c c V Double precision array N by NCV. (OUTPUT) c Upon INPUT: the NCV columns of V contain the Lanczos basis c vectors as constructed by dsaupd for OP. c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c represent the Ritz vectors that span the desired c invariant subspace. c NOTE: The array Z may be set equal to first NEV columns of the c Lanczos basis vector array V computed by dsaupd. In this case c if RVEC=.TRUE., the first NCONV=IPARAM(5) columns of V contain c the desired Ritz vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c It is set to 1 in this subroutine. The user do not need c to set this parameter. c ------------------------------------------------------------ c ISHIFT = 1: exact shifts with respect to the reduced c tridiagonal matrix T. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of Ritz vectors c associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced. c c IPARAM(3) = MXITER c On INPUT: max number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" eigenvalues. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4,5; See under \Description of dsband for the c five modes available. c c IPARAM(8) = NP c Not referenced. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c WORKD Double precision work array of length at least 3*n. (WORKSPACE) c c WORKL Double precision work array of length LWORKL. (WORKSPACE) c c LWORKL Integer. (INPUT) c LWORKL must be at least NCV**2 + 8*NCV. c c IWORK Integer array of dimension at least N. (WORKSPACE) c Used when IPARAM(7)=2,3,4,5 to store the pivot information in the c factorization of M or (A-SIGMA*M). c c INFO Integer. (INPUT/OUTPUT) c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 in DSAUPD. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Informational error from LAPACK routine dsteqr. c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: NEV and WHICH = 'BE' are incompatible. c = -13: HOWMNY must be one of 'A' or 'P' c = -14: DSAUPD did not find any eigenvalues to sufficient c accuracy. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current c Arnoldi factorization. c c \EndDoc c c------------------------------------------------------------------------ c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ, c May 1995. c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgbtrf LAPACK band matrix factorization routine. c dgbtrs LAPACK band linear system solve routine. c dlacpy LAPACK matrix copy routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dcopy Level 1 BLAS that copies one vector to another. c ddot Level 1 BLAS that computes the dot product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product. c c\Remarks c 1. The converged Ritz values are always returned in increasing c (algebraic) order. c c 2. Currently only HOWMNY = 'A' is implemented. It is included at this c stage for the user who wants to incorporate it. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sband.F SID: 2.3 DATE OF SID: 10/17/00 RELEASE: 2 c c\EndLib c c--------------------------------------------------------------------- c subroutine dsband( rvec, howmny, select, d, z, ldz, sigma, & n, ab, mb, lda, rfac, kl, ku, which, bmat, nev, & tol, resid, ncv, v, ldv, iparam, workd, workl, & lworkl, iwork, info) c c %------------------% c | Scalar Arguments | c %------------------% c character which*2, bmat, howmny integer n, lda, kl, ku, nev, ncv, ldv, & ldz, lworkl, info Double precision & tol, sigma logical rvec c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(*), iwork(*) logical select(*) Double precision & d(*), resid(*), v(ldv,*), z(ldz,*), & ab(lda,*), mb(lda,*), rfac(lda,*), & workd(*), workl(*) c c %--------------% c | Local Arrays | c %--------------% c integer ipntr(14) c c %---------------% c | Local Scalars | c %---------------% c integer ido, i, j, type, imid, itop, ibot, ierr c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0, zero = 0.0) c c c %-----------------------------% c | LAPACK & BLAS routines used | c %-----------------------------% c Double precision & ddot, dnrm2, dlapy2 external ddot, dcopy, dgbmv, dgbtrf, & dgbtrs, dnrm2, dlapy2, dlacpy c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------------------% c | Set type of the problem to be solved. Check consistency | c | between BMAT and IPARAM(7). | c | type = 1 --> Solving standard problem in regular mode. | c | type = 2 --> Solving standard problem in shift-invert mode. | c | type = 3 --> Solving generalized problem in regular mode. | c | type = 4 --> Solving generalized problem in shift-invert mode. | c | type = 5 --> Solving generalized problem in Buckling mode. | c | type = 6 --> Solving generalized problem in Cayley mode. | c %----------------------------------------------------------------% c if ( iparam(7) .eq. 1 ) then type = 1 else if ( iparam(7) .eq. 3 .and. bmat .eq. 'I') then type = 2 else if ( iparam(7) .eq. 2 ) then type = 3 else if ( iparam(7) .eq. 3 .and. bmat .eq. 'G') then type = 4 else if ( iparam(7) .eq. 4 ) then type = 5 else if ( iparam(7) .eq. 5 ) then type = 6 else print*, ' ' print*, 'BMAT is inconsistent with IPARAM(7).' print*, ' ' go to 9000 end if c c %------------------------% c | Initialize the reverse | c | communication flag. | c %------------------------% c ido = 0 c c %----------------% c | Exact shift is | c | used. | c %----------------% c iparam(1) = 1 c c %-----------------------------------% c | Both matrices A and M are stored | c | between rows itop and ibot. Imid | c | is the index of the row that | c | stores the diagonal elements. | c %-----------------------------------% c itop = kl + 1 imid = kl + ku + 1 ibot = 2*kl + ku + 1 c if ( type .eq. 2 .or. type .eq. 6 .and. bmat .eq. 'I' ) then c c %----------------------------------% c | Solving a standard eigenvalue | c | problem in shift-invert or | c | Cayley mode. Factor (A-sigma*I). | c %----------------------------------% c call dlacpy ('A', ibot, n, ab, lda, rfac, lda ) do 10 j = 1, n rfac(imid,j) = ab(imid,j) - sigma 10 continue call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr ) if (ierr .ne. 0) then print*, ' ' print*, ' _SBAND: Error with _gbtrf. ' print*, ' ' go to 9000 end if c else if ( type .eq. 3 ) then c c %----------------------------------------------% c | Solving generalized eigenvalue problem in | c | regular mode. Copy M to rfac and Call LAPACK | c | routine dgbtrf to factor M. | c %----------------------------------------------% c call dlacpy ('A', ibot, n, mb, lda, rfac, lda ) call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr) if (ierr .ne. 0) then print*, ' ' print*,'_SBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 .or. type .eq. 5 .or. type .eq. 6 & .and. bmat .eq. 'G' ) then c c %-------------------------------------------% c | Solving generalized eigenvalue problem in | c | shift-invert, Buckling, or Cayley mode. | c %-------------------------------------------% c c %-------------------------------------% c | Construct and factor (A - sigma*M). | c %-------------------------------------% c do 60 j = 1,n do 50 i = itop, ibot rfac(i,j) = ab(i,j) - sigma*mb(i,j) 50 continue 60 continue c call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_SBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c end if c c %--------------------------------------------% c | M A I N L O O P (reverse communication) | c %--------------------------------------------% c 90 continue c call dsaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1) then c if ( type .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( type .eq. 2 ) then c c %----------------------------------% c | Perform | c | y <--- OP*x = inv[A-sigma*I]*x | c | to force the starting vector | c | into the range of OP. | c %----------------------------------% c call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _SBAND: Error with _bgtrs. ' print*, ' ' go to 9000 end if c else if ( type .eq. 3 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c | to force the starting vector into | c | the range of OP. | c %-----------------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) call dcopy(n, workd(ipntr(2)), 1, workd(ipntr(1)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: Error with sbgtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 ) then c c %-----------------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*M | c | to force the starting vector into the | c | range of OP. | c %-----------------------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 5) then c c %---------------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*A | c | to force the starting vector into the | c | range of OP. | c %---------------------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) call dgbtrs('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) c if ( ierr .ne. 0 ) then print*, ' ' print*, ' _SBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c else if ( type .eq. 6 ) then c c %---------------------------------------% c | Perform y <-- OP*x | c | = (inv[A-SIGMA*M])*(A+SIGMA*M)*x | c | to force the starting vector into the | c | range of OP. | c %---------------------------------------% c if ( bmat .eq. 'G' ) then call dgbmv('Notranspose', n, n, kl, ku, one, & ab(itop,1), lda, workd(ipntr(1)), 1, & zero, workd(ipntr(2)), 1) call dgbmv('Notranspose', n, n, kl, ku, sigma, & mb(itop,1), lda, workd(ipntr(1)), 1, & one, workd(ipntr(2)), 1) else call dcopy(n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, sigma, & workd(ipntr(2)), 1) end if c call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) c if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c end if c else if (ido .eq. 1) then c if ( type .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( type .eq. 2) then c c %----------------------------------% c | Perform | c | y <--- OP*x = inv[A-sigma*I]*x. | c %----------------------------------% c call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_SBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 3 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c %-----------------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) call dcopy(n, workd(ipntr(2)), 1, workd(ipntr(1)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: error with _bgtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 ) then c c %-------------------------------------% c | Perform y <-- inv(A-sigma*M)*(M*x). | c | (M*x) has been computed and stored | c | in workd(ipntr(3)). | c %-------------------------------------% c call dcopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 5 ) then c c %-------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*A*x | c | B*x = A*x has been computed | c | and saved in workd(ipntr(3)). | c %-------------------------------% c call dcopy (n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call dgbtrs('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _SBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c else if ( type .eq. 6) then c c %---------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*(A+SIGMA*M)*x. | c | (M*x) has been saved in | c | workd(ipntr(3)). | c %---------------------------------% c if ( bmat .eq. 'G' ) then call dgbmv('Notranspose', n, n, kl, ku, one, & ab(itop,1), lda, workd(ipntr(1)), 1, & zero, workd(ipntr(2)), 1) call daxpy( n, sigma, workd(ipntr(3)), 1, & workd(ipntr(2)), 1 ) else call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, sigma, & workd(ipntr(2)), 1) end if call dgbtrs('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) c end if c else if (ido .eq. 2) then c c %----------------------------------% c | Perform y <-- B*x | c | Note when Buckling mode is used, | c | B = A, otherwise B=M. | c %----------------------------------% c if (type .eq. 5) then c c %---------------------% c | Buckling Mode, B=A. | c %---------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, & ab(itop,1), lda, workd(ipntr(1)), 1, & zero, workd(ipntr(2)), 1) else call dgbmv('Notranspose', n, n, kl, ku, one, & mb(itop,1), lda, workd(ipntr(1)), 1, & zero, workd(ipntr(2)), 1) end if c else c c %-----------------------------------------% c | Either we have convergence, or there is | c | error. | c %-----------------------------------------% c if ( info .lt. 0) then c c %--------------------------% c | Error message, check the | c | documentation in DSAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _saupd info = ',info print *, ' Check the documentation of _saupd ' print *, ' ' go to 9000 c else c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c if (iparam(5) .gt. 0) then c call dseupd ( rvec, 'A', select, d, z, ldz, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, info ) c if ( info .ne. 0) then c c %------------------------------------% c | Check the documentation of dneupd. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd = ', info print *, ' Check the documentation of _neupd ' print *, ' ' go to 9000 c end if c end if c end if c go to 9000 c end if c c %----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %----------------------------------------% c go to 90 c 9000 continue c end arpack-akloeckner-07/EXAMPLES/BAND/ssband.f0000644000175000017500000007667607172773061020076 0ustar andreasandreasc \BeginDoc c c \Name: ssband c c \Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal (Lanczos) basis for the associated approximate c invariant subspace; c c (3) Both. c c Matrices A and B are stored in LAPACK-style band form. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c (Lanczos) basis is always computed. There is an additional storage cost c of n*nev if both are requested (in this case a separate array Z must be c supplied). c c The approximate eigenvalues and eigenvectors of A*z = lambda*B*z c are called Ritz values and Ritz vectors respectively. They are referred c to as such in the comments that follow. The computed orthonormal basis c for the invariant subspace corresponding to these Ritz values is referred c to as a Lanczos basis. c c ssband can be called with one of the following modes: c c Mode 1: A*x = lambda*x, A symmetric c ===> OP = A and B = I. c c Mode 2: A*x = lambda*M*x, A symmetric, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c ===> (If M can be factored see remark 3 in SSAUPD) c c Mode 3: K*x = lambda*M*x, K symmetric, M symmetric positive semi-definite c ===> OP = (inv[K - sigma*M])*M and B = M. c ===> Shift-and-Invert mode c c Mode 4: K*x = lambda*KG*x, K symmetric positive semi-definite, c KG symmetric indefinite c ===> OP = (inv[K - sigma*KG])*K and B = K. c ===> Buckling mode c c Mode 5: A*x = lambda*M*x, A symmetric, M symmetric positive semi-definite c ===> OP = inv[A - sigma*M]*[A + sigma*M] and B = M. c ===> Cayley transformed mode c c The choice of mode must be specified in IPARAM(7) defined below. c c \Usage c call ssband c ( RVEC, HOWMNY, SELECT, D, Z, LDZ, SIGMA, N, AB, MB, LDA, c RFAC, KL, KU, WHICH, BMAT, NEV, TOL, RESID, NCV, V, c LDV, IPARAM, WORKD, WORKL, LWORKL, IWORK, INFO ) c c \Arguments c c RVEC Logical (INPUT) c Specifies whether Ritz vectors corresponding to the Ritz value c approximations to the eigenproblem A*z = lambda*B*z are computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute the associated Ritz vectors. c c HOWMNY Character*1 (INPUT) c Specifies how many Ritz vectors are wanted and the form of Z c the matrix of Ritz vectors. See remark 1 below. c = 'A': compute all Ritz vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value D(j), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' , SELECT is not referenced. c c D Real array of dimension NEV. (OUTPUT) c On exit, D contains the Ritz value approximations to the c eigenvalues of A*z = lambda*B*z. The values are returned c in ascending order. If IPARAM(7) = 3,4,5 then D represents c the Ritz values of OP computed by ssaupd transformed to c those of the original eigensystem A*z = lambda*B*z. If c IPARAM(7) = 1,2 then the Ritz values of OP are the same c as the those of A*z = lambda*B*z. c c Z Real N by NEV array if HOWMNY = 'A'. (OUTPUT) c On exit, Z contains the B-orthonormal Ritz vectors of the c eigensystem A*z = lambda*B*z corresponding to the Ritz c value approximations. c c If RVEC = .FALSE. then Z is not referenced. c NOTE: The array Z may be set equal to first NEV columns of the c Lanczos basis array V computed by SSAUPD. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ .ge. max( 1, N ). In any case, LDZ .ge. 1. c c SIGMA Real (INPUT) c If IPARAM(7) = 3,4,5 represents the shift. Not referenced if c IPARAM(7) = 1 or 2. c c N Integer. (INPUT) c Dimension of the eigenproblem. c c AB Real array of dimension LDA by N. (INPUT) c The matrix A in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of A is stored in the j-th column of the c array AB as follows: c AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c c MB Real array of dimension LDA by N. (INPUT) c The matrix M in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of M is stored in the j-th column of the c array AB as follows: c MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c Not referenced if IPARAM(7) = 1 c c LDA Integer. (INPUT) c Leading dimension of AB, MB, RFAC. c c RFAC Real array of LDA by N. (WORKSPACE/OUTPUT) c RFAC is used to store the LU factors of MB when IPARAM(7) = 2 c is invoked. It is used to store the LU factors of c (A-sigma*M) when IPARAM(7) = 3,4,5 is invoked. c It is not referenced when IPARAM(7) = 1. c c KL Integer. (INPUT) c Max(number of subdiagonals of A, number of subdiagonals of M) c c KU Integer. (OUTPUT) c Max(number of superdiagonals of A, number of superdiagonals of M) c c WHICH Character*2. (INPUT) c When IPARAM(7)= 1 or 2, WHICH can be set to any one of c the following. c c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LA' -> want the NEV eigenvalues of largest REAL part. c 'SA' -> want the NEV eigenvalues of smallest REAL part. c 'BE' -> Compute NEV eigenvalues, half from each end of the c spectrum. When NEV is odd, compute one more from c the high end than from the low end. c c When IPARAM(7) = 3, 4, or 5, WHICH should be set to 'LM' only. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*x = lambda*x c BMAT = 'G' -> generalized eigenvalue problem A*x = lambda*M*x c NEV Integer. (INPUT) c Number of eigenvalues of OP to be computed. c c TOL Real scalar. (INPUT) c Stopping criterion: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). c If TOL .LE. 0. is passed a default is set: c DEFAULT = SLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine SLAMCH). c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V (less than or equal to N). c Represents the dimension of the Lanczos basis constructed c by ssaupd for OP. c c V Real array N by NCV. (OUTPUT) c Upon INPUT: the NCV columns of V contain the Lanczos basis c vectors as constructed by ssaupd for OP. c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c represent the Ritz vectors that span the desired c invariant subspace. c NOTE: The array Z may be set equal to first NEV columns of the c Lanczos basis vector array V computed by ssaupd. In this case c if RVEC=.TRUE., the first NCONV=IPARAM(5) columns of V contain c the desired Ritz vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c It is set to 1 in this subroutine. The user do not need c to set this parameter. c ------------------------------------------------------------ c ISHIFT = 1: exact shifts with respect to the reduced c tridiagonal matrix T. This is equivalent to c restarting the iteration with a starting vector c that is a linear combination of Ritz vectors c associated with the "wanted" Ritz values. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced. c c IPARAM(3) = MXITER c On INPUT: max number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" eigenvalues. c This represents the number of Ritz values that satisfy c the convergence criterion. c c IPARAM(6) = IUPD c No longer referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = MODE c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4,5; See under \Description of ssband for the c five modes available. c c IPARAM(8) = NP c Not referenced. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*x operations, c NUMOPB = total number of B*x operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c WORKD Real work array of length at least 3*n. (WORKSPACE) c c WORKL Real work array of length LWORKL. (WORKSPACE) c c LWORKL Integer. (INPUT) c LWORKL must be at least NCV**2 + 8*NCV. c c IWORK Integer array of dimension at least N. (WORKSPACE) c Used when IPARAM(7)=2,3,4,5 to store the pivot information in the c factorization of M or (A-SIGMA*M). c c INFO Integer. (INPUT/OUTPUT) c Error flag on output. c = 0: Normal exit. c = 1: Maximum number of iterations taken. c All possible eigenvalues of OP has been found. IPARAM(5) c returns the number of wanted converged Ritz values. c = 3: No shifts could be applied during a cycle of the c Implicitly restarted Arnoldi iteration. One possibility c is to increase the size of NCV relative to NEV. c See remark 4 in SSAUPD. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from trid. eigenvalue calculation; c Informational error from LAPACK routine ssteqr. c = -9: Starting vector is zero. c = -10: IPARAM(7) must be 1,2,3,4,5. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: NEV and WHICH = 'BE' are incompatible. c = -13: HOWMNY must be one of 'A' or 'P' c = -14: SSAUPD did not find any eigenvalues to sufficient c accuracy. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current c Arnoldi factorization. c c \EndDoc c c------------------------------------------------------------------------ c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ, c May 1995. c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgbtrf LAPACK band matrix factorization routine. c sgbtrs LAPACK band linear system solve routine. c slacpy LAPACK matrix copy routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c scopy Level 1 BLAS that copies one vector to another. c sdot Level 1 BLAS that computes the dot product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product. c c\Remarks c 1. The converged Ritz values are always returned in increasing c (algebraic) order. c c 2. Currently only HOWMNY = 'A' is implemented. It is included at this c stage for the user who wants to incorporate it. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sband.F SID: 2.3 DATE OF SID: 10/17/00 RELEASE: 2 c c\EndLib c c--------------------------------------------------------------------- c subroutine ssband( rvec, howmny, select, d, z, ldz, sigma, & n, ab, mb, lda, rfac, kl, ku, which, bmat, nev, & tol, resid, ncv, v, ldv, iparam, workd, workl, & lworkl, iwork, info) c c %------------------% c | Scalar Arguments | c %------------------% c character which*2, bmat, howmny integer n, lda, kl, ku, nev, ncv, ldv, & ldz, lworkl, info Real & tol, sigma logical rvec c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(*), iwork(*) logical select(*) Real & d(*), resid(*), v(ldv,*), z(ldz,*), & ab(lda,*), mb(lda,*), rfac(lda,*), & workd(*), workl(*) c c %--------------% c | Local Arrays | c %--------------% c integer ipntr(14) c c %---------------% c | Local Scalars | c %---------------% c integer ido, i, j, type, imid, itop, ibot, ierr c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0, zero = 0.0) c c c %-----------------------------% c | LAPACK & BLAS routines used | c %-----------------------------% c Real & sdot, snrm2, slapy2 external sdot, scopy, sgbmv, sgbtrf, & sgbtrs, snrm2, slapy2, slacpy c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------------------% c | Set type of the problem to be solved. Check consistency | c | between BMAT and IPARAM(7). | c | type = 1 --> Solving standard problem in regular mode. | c | type = 2 --> Solving standard problem in shift-invert mode. | c | type = 3 --> Solving generalized problem in regular mode. | c | type = 4 --> Solving generalized problem in shift-invert mode. | c | type = 5 --> Solving generalized problem in Buckling mode. | c | type = 6 --> Solving generalized problem in Cayley mode. | c %----------------------------------------------------------------% c if ( iparam(7) .eq. 1 ) then type = 1 else if ( iparam(7) .eq. 3 .and. bmat .eq. 'I') then type = 2 else if ( iparam(7) .eq. 2 ) then type = 3 else if ( iparam(7) .eq. 3 .and. bmat .eq. 'G') then type = 4 else if ( iparam(7) .eq. 4 ) then type = 5 else if ( iparam(7) .eq. 5 ) then type = 6 else print*, ' ' print*, 'BMAT is inconsistent with IPARAM(7).' print*, ' ' go to 9000 end if c c %------------------------% c | Initialize the reverse | c | communication flag. | c %------------------------% c ido = 0 c c %----------------% c | Exact shift is | c | used. | c %----------------% c iparam(1) = 1 c c %-----------------------------------% c | Both matrices A and M are stored | c | between rows itop and ibot. Imid | c | is the index of the row that | c | stores the diagonal elements. | c %-----------------------------------% c itop = kl + 1 imid = kl + ku + 1 ibot = 2*kl + ku + 1 c if ( type .eq. 2 .or. type .eq. 6 .and. bmat .eq. 'I' ) then c c %----------------------------------% c | Solving a standard eigenvalue | c | problem in shift-invert or | c | Cayley mode. Factor (A-sigma*I). | c %----------------------------------% c call slacpy ('A', ibot, n, ab, lda, rfac, lda ) do 10 j = 1, n rfac(imid,j) = ab(imid,j) - sigma 10 continue call sgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr ) if (ierr .ne. 0) then print*, ' ' print*, ' _SBAND: Error with _gbtrf. ' print*, ' ' go to 9000 end if c else if ( type .eq. 3 ) then c c %----------------------------------------------% c | Solving generalized eigenvalue problem in | c | regular mode. Copy M to rfac and Call LAPACK | c | routine sgbtrf to factor M. | c %----------------------------------------------% c call slacpy ('A', ibot, n, mb, lda, rfac, lda ) call sgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr) if (ierr .ne. 0) then print*, ' ' print*,'_SBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 .or. type .eq. 5 .or. type .eq. 6 & .and. bmat .eq. 'G' ) then c c %-------------------------------------------% c | Solving generalized eigenvalue problem in | c | shift-invert, Buckling, or Cayley mode. | c %-------------------------------------------% c c %-------------------------------------% c | Construct and factor (A - sigma*M). | c %-------------------------------------% c do 60 j = 1,n do 50 i = itop, ibot rfac(i,j) = ab(i,j) - sigma*mb(i,j) 50 continue 60 continue c call sgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_SBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c end if c c %--------------------------------------------% c | M A I N L O O P (reverse communication) | c %--------------------------------------------% c 90 continue c call ssaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1) then c if ( type .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( type .eq. 2 ) then c c %----------------------------------% c | Perform | c | y <--- OP*x = inv[A-sigma*I]*x | c | to force the starting vector | c | into the range of OP. | c %----------------------------------% c call scopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _SBAND: Error with _bgtrs. ' print*, ' ' go to 9000 end if c else if ( type .eq. 3 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c | to force the starting vector into | c | the range of OP. | c %-----------------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) call scopy(n, workd(ipntr(2)), 1, workd(ipntr(1)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: Error with sbgtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 ) then c c %-----------------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*M | c | to force the starting vector into the | c | range of OP. | c %-----------------------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 5) then c c %---------------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*A | c | to force the starting vector into the | c | range of OP. | c %---------------------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) call sgbtrs('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) c if ( ierr .ne. 0 ) then print*, ' ' print*, ' _SBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c else if ( type .eq. 6 ) then c c %---------------------------------------% c | Perform y <-- OP*x | c | = (inv[A-SIGMA*M])*(A+SIGMA*M)*x | c | to force the starting vector into the | c | range of OP. | c %---------------------------------------% c if ( bmat .eq. 'G' ) then call sgbmv('Notranspose', n, n, kl, ku, one, & ab(itop,1), lda, workd(ipntr(1)), 1, & zero, workd(ipntr(2)), 1) call sgbmv('Notranspose', n, n, kl, ku, sigma, & mb(itop,1), lda, workd(ipntr(1)), 1, & one, workd(ipntr(2)), 1) else call scopy(n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, sigma, & workd(ipntr(2)), 1) end if c call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) c if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c end if c else if (ido .eq. 1) then c if ( type .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( type .eq. 2) then c c %----------------------------------% c | Perform | c | y <--- OP*x = inv[A-sigma*I]*x. | c %----------------------------------% c call scopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_SBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 3 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c %-----------------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) call scopy(n, workd(ipntr(2)), 1, workd(ipntr(1)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: error with _bgtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 ) then c c %-------------------------------------% c | Perform y <-- inv(A-sigma*M)*(M*x). | c | (M*x) has been computed and stored | c | in workd(ipntr(3)). | c %-------------------------------------% c call scopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_SBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 5 ) then c c %-------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*A*x | c | B*x = A*x has been computed | c | and saved in workd(ipntr(3)). | c %-------------------------------% c call scopy (n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call sgbtrs('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _SBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c else if ( type .eq. 6) then c c %---------------------------------% c | Perform y <-- OP*x | c | = inv[A-SIGMA*M]*(A+SIGMA*M)*x. | c | (M*x) has been saved in | c | workd(ipntr(3)). | c %---------------------------------% c if ( bmat .eq. 'G' ) then call sgbmv('Notranspose', n, n, kl, ku, one, & ab(itop,1), lda, workd(ipntr(1)), 1, & zero, workd(ipntr(2)), 1) call saxpy( n, sigma, workd(ipntr(3)), 1, & workd(ipntr(2)), 1 ) else call scopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, sigma, & workd(ipntr(2)), 1) end if call sgbtrs('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) c end if c else if (ido .eq. 2) then c c %----------------------------------% c | Perform y <-- B*x | c | Note when Buckling mode is used, | c | B = A, otherwise B=M. | c %----------------------------------% c if (type .eq. 5) then c c %---------------------% c | Buckling Mode, B=A. | c %---------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, & ab(itop,1), lda, workd(ipntr(1)), 1, & zero, workd(ipntr(2)), 1) else call sgbmv('Notranspose', n, n, kl, ku, one, & mb(itop,1), lda, workd(ipntr(1)), 1, & zero, workd(ipntr(2)), 1) end if c else c c %-----------------------------------------% c | Either we have convergence, or there is | c | error. | c %-----------------------------------------% c if ( info .lt. 0) then c c %--------------------------% c | Error message, check the | c | documentation in SSAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _saupd info = ',info print *, ' Check the documentation of _saupd ' print *, ' ' go to 9000 c else c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c if (iparam(5) .gt. 0) then c call sseupd ( rvec, 'A', select, d, z, ldz, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, info ) c if ( info .ne. 0) then c c %------------------------------------% c | Check the documentation of sneupd. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd = ', info print *, ' Check the documentation of _neupd ' print *, ' ' go to 9000 c end if c end if c end if c go to 9000 c end if c c %----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %----------------------------------------% c go to 90 c 9000 continue c end arpack-akloeckner-07/EXAMPLES/BAND/dnband.f0000644000175000017500000014547107172770664020046 0ustar andreasandreasc \BeginDoc c c \Name: dnband c c \Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c Matrices A and B are stored in LAPACK-style banded form. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c dnband can be called with one of the following modes: c c Mode 1: A*z = lambda*z. c ===> OP = A and B = I. c c Mode 2: A*z = lambda*M*z, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c c Mode 3: A*z = lambda*M*z, M symmetric semi-definite c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*z = amu*z, then c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. c Note: If sigma is real, i.e. imaginary part of sigma is zero; c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M c amu == 1/(lambda-sigma). c c Mode 4: A*z = lambda*M*z, M symmetric semi-definite c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*z = amu*z, then c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. c c c The choice of mode must be specified in IPARAM(7) defined below. c c \Usage c call dnband c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, c WORKEV, V, N, AB, MB, LDA, RFAC, CFAC, KL, KU, WHICH, c BMAT, NEV, TOL, RESID, NCV, V, LDV, IPARAM, WORKD, c WORKL, LWORKL, WORKC, IWORK, INFO ) c c \Arguments c c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. c c DR Double precision array of dimension NEV+1. (OUTPUT) c On exit, DR contains the real part of the Ritz value approximations c to the eigenvalues of A*z = lambda*B*z. c c DI Double precision array of dimension NEV+1. (OUTPUT) c On exit, DI contains the imaginary part of the Ritz value c approximations to the eigenvalues of A*z = lambda*B*z associated c with DR. c c NOTE: When Ritz values are complex, they will come in complex c conjugate pairs. If eigenvectors are requested, the c corresponding Ritz vectors will also come in conjugate c pairs and the real and imaginary parts of these are c represented in two consecutive columns of the array Z c (see below). c c Z Real N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) c On exit, c if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represent approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z computed by DNAUPD. c c The complex Ritz vector associated with the Ritz value c with positive imaginary part is stored in two consecutive c columns. The first column holds the real part of the Ritz c vector and the second column holds the imaginary part. The c Ritz vector associated with the Ritz value with negative c imaginary part is simply the complex conjugate of the Ritz vector c associated with the positive imaginary part. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by DNAUPD. In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. c c SIGMAR Double precision (INPUT) c If IPARAM(7) = 3 or 4, represents the real part of the shift. c Not referenced if IPARAM(7) = 1 or 2. c c SIGMAI Double precision (INPUT) c If IPARAM(7) = 3 or 4, represents the imaginary part of the c shift. c Not referenced if IPARAM(7) = 1 or 2. c c WORKEV Double precision work array of dimension 3*NCV. (WORKSPACE) c c N Integer. (INPUT) c Dimension of the eigenproblem. c c AB Double precision array of dimension LDA by N. (INPUT) c The matrix A in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of A is stored in the j-th column of the c array AB as follows: c AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c c MB Double precision array of dimension LDA by N. (INPUT) c The matrix M in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of M is stored in the j-th column of the c array AB as follows: c MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c Not referenced if IPARAM(7) = 1 c c LDA Integer. (INPUT) c Leading dimension of AB, MB, RFAC and CFAC. c c RFAC Double precision array of LDA by N. (WORKSPACE/OUTPUT) c RFAC is used to store the LU factors of MB when IPARAM(7) = 2 c is invoked. It is used to store the LU factors of c (A-sigma*M) when IPARAM(7) = 3 is invoked with a real shift. c It is not referenced when IPARAM(7) = 1 or 4. c c CFAC Complex*16 array of LDA by N. (WORKSPACE/OUTPUT) c CFAC is used to store (A-SIGMA*M) and its LU factors c when IPARAM(7) = 3 or 4 are used with a complex shift SIGMA. c On exit, it contains the LU factors of (A-SIGMA*M). c It is not referenced when IPARAM(7) = 1 or 2. c c KL Integer. (INPUT) c Max(number of subdiagonals of A, number of subdiagonals of M) c c KU Integer. (OUTPUT) c Max(number of superdiagonals of A, number of superdiagonals of M) c c WHICH Character*2. (INPUT) c When IPARAM(7)= 1 or 2, WHICH can be set to any one of c the following. c c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c When IPARAM(7) = 3 or 4, WHICH should be set to 'LM' only. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*z = lambda*z c BMAT = 'G' -> generalized eigenvalue problem A*z = lambda*M*z c NEV Integer. (INPUT) c Number of eigenvalues to be computed. c c TOL Double precision scalar. (INPUT) c Stopping criteria: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). c If TOL .LE. 0. is passed a default is set: c DEFAULT = DLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine DLAMCH). c c RESID Double precision array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V (less than or equal to N). c Represents the dimension of the Arnoldi basis constructed c by dnaupd for OP. c c V Double precision array N by NCV+1. (OUTPUT) c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c represent approximate Schur vectors that span the c desired invariant subspace. c NOTE: The array Z may be set equal to first NEV+1 columns of the c Arnoldi basis vector array V computed by DNAUPD. In this case c if RVEC = .TRUE. and HOWMNY='A', then the first NCONV=IPARAM(5) c are the desired Ritz vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c It is set to 1 in this subroutine. The user do not need c to set this parameter. c ---------------------------------------------------------- c ISHIFT = 1: exact shift with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration from the beginning c after updating the starting vector with a linear c combination of Ritz vectors associated with the c "wanted" eigenvalues. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced. c c IPARAM(3) = MXITER c On INPUT: max number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" eigenvalues. c c IPARAM(6) = IUPD c Not referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = IPARAM(7): c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4; See under \Description of dnband for the c four modes available. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*z operations, c NUMOPB = total number of B*z operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c WORKD Double precision work array of length at least 3*n. (WORKSPACE) c c WORKL Double precision work array of length LWORKL. (WORKSPACE) c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 6*NCV. c c WORKC Complex*16 array of length N. (WORKSPACE) c Workspace used when IPARAM(7) = 3 or 4 for storing a temporary c complex vector. c c IWORK Integer array of dimension at least N. (WORKSPACE) c Used when IPARAM(7)=2,3,4 to store the pivot information in the c factorization of M or (A-SIGMA*M). c c INFO Integer. (INPUT/OUTPUT) c Error flag on output. c = 0: Normal exit. c = 1: The Schur form computed by LAPACK routine dlahqr c could not be reordered by LAPACK routine dtrsen. c Re-enter subroutine DNEUPD with IPARAM(5)=NCV and c increase the size of the arrays DR and DI to have c dimension at least NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from calculation of a real Schur form. c Informational error from LAPACK routine dlahqr. c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine dtrevc. c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' c = -14: DNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: Overflow occurs when we try to transform the Ritz c values returned from DNAUPD to those of the original c problem using Rayleigh Quotient. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current c Arnoldi factorization. c c \EndDoc c c------------------------------------------------------------------------ c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ, c May 1995. c c\Routines called: c dnaupd ARPACK reverse communication interface routine. c dneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgbtrf LAPACK band matrix factorization routine. c dgbtrs LAPACK band linear system solve routine. c zgbtrf LAPACK complex band matrix factorization routine. c zgbtrs LAPACK complex linear system solve routine. c dlacpy LAPACK matrix copy routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dlamch LAPACK routine to compute the underflow threshold. c dcopy Level 1 BLAS that copies one vector to another. c ddot Level 1 BLAS that computes the dot product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c dgbmv Level 2 BLAS that computes the band matrix vector product. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c Let X' denote the transpose of X. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .TRUE. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c V(:,1:IPARAM(5))' * V(:,1:IPARAM(5)) = I are approximately satisfied. c Here T is the leading submatrix of order IPARAM(5) of the real c upper quasi-triangular matrix stored workl(ipntr(12)). That is, c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; c each 2-by-2 diagonal block has its diagonal elements equal and its c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 c diagonal block is a complex conjugate pair of Ritz values. The real c Ritz values are stored on the diagonal of T. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nband.F SID: 2.3 DATE OF SID: 10/17/00 RELEASE: 2 c c\EndLib c c--------------------------------------------------------------------- c subroutine dnband( rvec, howmny, select, dr, di, z, ldz, sigmar, & sigmai, workev, n, ab, mb, lda, rfac, cfac, kl, ku, & which, bmat, nev, tol, resid, ncv, v, ldv, & iparam, workd, workl, lworkl, workc, iwork, info) c c %------------------% c | Scalar Arguments | c %------------------% c character which*2, bmat, howmny integer n, lda, kl, ku, nev, ncv, ldv, & ldz, lworkl, info Double precision & tol, sigmar, sigmai c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(*), iwork(*) logical select(*) Double precision & dr(*), di(*), resid(*), v(ldv,*), z(ldz,*), & ab(lda,*), mb(lda,*), rfac(lda,*), & workd(*), workl(*), workev(*) Complex*16 & cfac(lda,*), workc(*) c c %--------------% c | Local Arrays | c %--------------% c integer ipntr(14) c c %---------------% c | Local Scalars | c %---------------% c integer ido, i, j, type, imid, itop, ibot, ierr Double precision & numr, denr, deni, dmdul, safmin logical rvec, first c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c c %-----------------------------% c | LAPACK & BLAS routines used | c %-----------------------------% c Double precision & ddot, dnrm2, dlapy2, dlamch external ddot, dcopy, dgbmv, zgbtrf, zgbtrs, dgbtrf, & dgbtrs, dnrm2, dlapy2, dlacpy, dlamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c Intrinsic dble, dimag, dcmplx c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------% c | safmin = safe minimum is such | c | that 1/sfmin does not overflow | c %--------------------------------% c safmin = dlamch('safmin') c c %----------------------------------------------------------------% c | Set type of the problem to be solved. Check consistency | c | between BMAT and IPARAM(7). | c | type = 1 --> Solving standard problem in regular mode. | c | type = 2 --> Solving standard problem in shift-invert mode. | c | type = 3 --> Solving generalized problem in regular mode. | c | type = 4 --> Solving generalized problem in shift-invert mode. | c | type = 5 --> Solving standard problem in shift-invert mode | c | using iparam(7) = 4 in DNAUPD. | c | type = 6 --> Solving generalized problem in shift-invert mode. | c | using iparam(7) = 4 in DNAUPD. | c %----------------------------------------------------------------% c if ( iparam(7) .eq. 1 ) then type = 1 else if ( iparam(7) .eq. 3 .and. bmat .eq. 'I') then type = 2 else if ( iparam(7) .eq. 2 ) then type = 3 else if ( iparam(7) .eq. 3 .and. bmat .eq. 'G') then type = 4 else if ( iparam(7) .eq. 4 .and. bmat .eq. 'I') then type = 5 else if ( iparam(7) .eq. 4 .and. bmat .eq. 'G') then type = 6 else print*, ' ' print*, 'BMAT is inconsistent with IPARAM(7).' print*, ' ' go to 9000 end if c c %----------------------------------% c | When type = 5,6 are used, sigmai | c | must be nonzero. | c %----------------------------------% c if ( type .eq. 5 .or. type .eq. 6 ) then if ( sigmai .eq. zero ) then print*, ' ' print*, '_NBAND: sigmai must be nonzero when type 5 or 6 & is used. ' print*, ' ' go to 9000 end if end if c c %------------------------% c | Initialize the reverse | c | communication flag. | c %------------------------% c ido = 0 c c %----------------% c | Exact shift is | c | used. | c %----------------% c iparam(1) = 1 c c %-----------------------------------% c | Both matrices A and M are stored | c | between rows itop and ibot. Imid | c | is the index of the row that | c | stores the diagonal elements. | c %-----------------------------------% c itop = kl + 1 imid = kl + ku + 1 ibot = 2*kl + ku + 1 c if ( type .eq. 2 .or. type .eq. 5 ) then c c %-------------------------------% c | Solving a standard eigenvalue | c | problem in shift-invert mode. | c | Factor (A-sigma*I). | c %-------------------------------% c if (sigmai .eq. zero) then c c %-----------------------------------% c | Construct (A-sigmar*I) and factor | c | in real arithmetic. | c %-----------------------------------% c call dlacpy ('A', ibot, n, ab, lda, rfac, lda ) do 10 j = 1, n rfac(imid,j) = ab(imid,j) - sigmar 10 continue call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr ) if (ierr .ne. 0) then print*, ' ' print*, ' _NBAND: Error with _gbtrf. ' print*, ' ' go to 9000 end if c else c c %-----------------------------------% c | Construct (A-sigmar*I) and factor | c | in COMPLEX arithmetic. | c %-----------------------------------% c do 30 j = 1, n do 20 i = itop, ibot cfac(i,j) = dcmplx(ab(i,j)) 20 continue 30 continue c do 40 j = 1, n cfac(imid,j) = cfac(imid,j) $ - dcmplx(sigmar, sigmai) 40 continue c call zgbtrf(n, n, kl, ku, cfac, lda, iwork, ierr ) if ( ierr .ne. 0) then print*, ' ' print*, ' _NBAND: Error with _gbtrf. ' print*, ' ' go to 9000 end if c end if else if ( type .eq. 3 ) then c c %-----------------------------------------------% c | Solving generalized eigenvalue problem in | c | regular mode. Copy M to rfac, and call LAPACK | c | routine dgbtrf to factor M. | c %-----------------------------------------------% c call dlacpy ('A', ibot, n, mb, lda, rfac, lda ) call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr) if (ierr .ne. 0) then print*, ' ' print*,'_NBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 .or. type .eq. 6 ) then c c %-------------------------------------------% c | Solving generalized eigenvalue problem in | c | shift-invert mode. | c %-------------------------------------------% c if ( sigmai .eq. zero ) then c c %--------------------------------------------% c | Construct (A - sigma*M) and factor in real | c | arithmetic. | c %--------------------------------------------% c do 60 j = 1,n do 50 i = itop, ibot rfac(i,j) = ab(i,j) - sigmar*mb(i,j) 50 continue 60 continue c call dgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_NBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c else c c %-----------------------------------------------% c | Construct (A - sigma*M) and factor in complex | c | arithmetic. | c %-----------------------------------------------% c do 80 j = 1,n do 70 i = itop, ibot cfac(i,j) = dcmplx( ab(i,j)-sigmar*mb(i,j), & -sigmai*mb(i,j) ) 70 continue 80 continue c call zgbtrf(n, n, kl, ku, cfac, lda, iwork, ierr) if ( ierr .NE. 0 ) then print*, ' ' print*, '_NBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c end if c end if c c %--------------------------------------------% c | M A I N L O O P (reverse communication) | c %--------------------------------------------% c 90 continue c call dnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1) then c if ( type .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( type .eq. 2 ) then c if (sigmai .eq. zero) then c c %----------------------------------% c | Shift is real. Perform | c | y <--- OP*x = inv[A-sigmar*I]*x | c | to force the starting vector | c | into the range of OP. | c %----------------------------------% c call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _NBAND: Error with _bgtrs. ' print*, ' ' go to 9000 end if c else c c %--------------------------------------------% c | Shift is COMPLEX. Perform | c | y <--- OP*x = Real_Part{inv[A-sigma*I]*x} | c | to force the starting vector into the | c | range of OP. | c %--------------------------------------------% c do 100 j = 1, n workc(j) = dcmplx(workd(ipntr(1)+j-1)) 100 continue c call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _NBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c do 110 j = 1, n workd(ipntr(2)+j-1) = dble(workc(j)) 110 continue c end if c else if ( type .eq. 3 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c | to force the starting vector into | c | the range of OP. | c %-----------------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _bgtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 ) then c c %-----------------------------------------% c | Perform y <-- OP*x | c | = Real_part{inv[A-SIGMA*M]*M}*x | c | to force the starting vector into the | c | range of OP. | c %-----------------------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c if ( sigmai .eq. zero ) then c c %---------------------% c | Shift is real, stay | c | in real arithmetic. | c %---------------------% c call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else c c %--------------------------% c | Goto complex arithmetic. | c %--------------------------% c do 120 i = 1,n workc(i) = dcmplx(workd(ipntr(2)+i-1)) 120 continue c call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c do 130 i = 1, n workd(ipntr(2)+i-1) = dble(workc(i)) 130 continue c end if c else if ( type .eq. 5) then c c %---------------------------------------% c | Perform y <-- OP*x | c | = Imaginary_part{inv[A-SIGMA*I]}*x | c | to force the starting vector into the | c | range of OP. | c %---------------------------------------% c do 140 j = 1, n workc(j) = dcmplx(workd(ipntr(1)+j-1)) 140 continue c call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _NBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c do 150 j = 1, n workd(ipntr(2)+j-1) = dimag(workc(j)) 150 continue c else if ( type .eq. 6 ) then c c %----------------------------------------% c | Perform y <-- OP*x | c | Imaginary_part{inv[A-SIGMA*M]*M} | c | to force the starting vector into the | c | range of OP. | c %----------------------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c do 160 i = 1,n workc(i) = dcmplx(workd(ipntr(2)+i-1)) 160 continue c call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c do 170 i = 1, n workd(ipntr(2)+i-1) = dimag(workc(i)) 170 continue c end if c else if (ido .eq. 1) then c if ( type .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( type .eq. 2) then c if ( sigmai .eq. zero) then c c %----------------------------------% c | Shift is real. Perform | c | y <--- OP*x = inv[A-sigmar*I]*x. | c %----------------------------------% c call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) else c c %------------------------------------------% c | Shift is COMPLEX. Perform | c | y <-- OP*x = Real_Part{inv[A-sigma*I]*x} | c | in COMPLEX arithmetic. | c %------------------------------------------% c do 180 j = 1, n workc(j) = dcmplx(workd(ipntr(1)+j-1)) 180 continue c call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c do 190 j = 1, n workd(ipntr(2)+j-1) = dble(workc(j)) 190 continue c end if c else if ( type .eq. 3 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c %-----------------------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _bgtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 ) then c c %--------------------------------------% c | Perform y <-- inv(A-sigma*M)*(M*x). | c | (M*x) has been computed and stored | c | in workd(ipntr(3)). | c %--------------------------------------% c if ( sigmai .eq. zero ) then c c %------------------------% c | Shift is real, stay in | c | real arithmetic. | c %------------------------% c call dcopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call dgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else c c %---------------------------% c | Go to COMPLEX arithmetic. | c %---------------------------% c do 200 i = 1,n workc(i) = dcmplx(workd(ipntr(3)+i-1)) 200 continue c call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error in _gbtrs.' print*, ' ' go to 9000 end if c do 210 i = 1,n workd(ipntr(2)+i-1) = dble(workc(i)) 210 continue c end if c else if ( type .eq. 5 ) then c c %---------------------------------------% c | Perform y <-- OP*x | c | = Imaginary_part{inv[A-SIGMA*I]*x} | c %---------------------------------------% c do 220 j = 1, n workc(j) = dcmplx(workd(ipntr(1)+j-1)) 220 continue c call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _NBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c do 230 j = 1, n workd(ipntr(2)+j-1) = dimag(workc(j)) 230 continue c else if ( type .eq. 6) then c c %-----------------------------------------% c | Perform y <-- OP*x | c | = Imaginary_part{inv[A-SIGMA*M]*M}*x. | c %-----------------------------------------% c do 240 i = 1,n workc(i) = dcmplx(workd(ipntr(3)+i-1)) 240 continue c call zgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c do 250 i = 1, n workd(ipntr(2)+i-1) = dimag(workc(i)) 250 continue c end if c else if (ido .eq. 2) then c c %--------------------% c | Perform y <-- M*x | c | Not used when | c | type = 1,2. | c %--------------------% c call dgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else c c %-----------------------------------------% c | Either we have convergence, or there is | c | error. | c %-----------------------------------------% c if ( info .lt. 0) then c c %--------------------------% c | Error message, check the | c | documentation in DNAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _naupd info = ',info print *, ' Check the documentation of _naupd ' print *, ' ' go to 9000 c else c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c if (iparam(5) .gt. 0) then c call dneupd ( rvec, 'A', select, dr, di, z, ldz, & sigmar, sigmai, workev, bmat, n, which, & nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c if ( info .ne. 0) then c c %------------------------------------% c | Check the documentation of DNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd = ', info print *, ' Check the documentation of _neupd ' print *, ' ' go to 9000 c else if ( sigmai .ne. zero ) then c if ( type .eq. 4 .or. type .eq. 6 ) then c first = .true. do 270 j = 1, iparam(5) c c %----------------------------------% c | Use Rayleigh Quotient to recover | c | eigenvalues of the original | c | generalized eigenvalue problem. | c %----------------------------------% c if ( di(j) .eq. zero ) then c c %--------------------------------------% c | Eigenvalue is real. Compute | c | d = (x'*inv[A-sigma*M]*M*x) / (x'*x) | c %--------------------------------------% c call dgbmv('Nontranspose', n, n, kl, ku, one, $ mb(itop,1), lda, z(1,j), 1, zero, $ workd, 1) do i = 1, n workc(i) = dcmplx(workd(i)) end do call zgbtrs ('Notranspose', n, kl, ku, 1, $ cfac, lda, iwork, workc, n, info) do i = 1, n workd(i) = dble(workc(i)) workd(i+n) = dimag(workc(i)) end do denr = ddot(n, z(1,j), 1, workd, 1) deni = ddot(n, z(1,j), 1, workd(n+1), 1) numr = dnrm2(n, z(1,j), 1)**2 dmdul = dlapy2(denr,deni)**2 if ( dmdul .ge. safmin ) then dr(j) = sigmar + numr*denr / dmdul else c c %---------------------% c | dmdul is too small. | c | Exit to avoid | c | overflow. | c %---------------------% c info = -15 go to 9000 end if c else if (first) then c c %------------------------% c | Eigenvalue is complex. | c | Compute the first one | c | of the conjugate pair. | c %------------------------% c c %-------------% c | Compute M*x | c %-------------% c call dgbmv('Nontranspose', n, n, kl, ku, $ one, mb(itop,1), lda, z(1,j), 1, zero, $ workd, 1) call dgbmv('Nontranspose', n, n, kl, ku, $ one, mb(itop,1), lda, z(1,j+1), 1, $ zero, workd(n+1), 1) do i = 1, n workc(i) = dcmplx(workd(i),workd(i+n)) end do c c %----------------------------% c | Compute inv(A-sigma*M)*M*x | c %----------------------------% c call zgbtrs('Notranspose',n,kl,ku,1,cfac, $ lda, iwork, workc, n, info) c c %-------------------------------% c | Compute x'*inv(A-sigma*M)*M*x | c %-------------------------------% c do i = 1, n workd(i) = dble(workc(i)) workd(i+n) = dimag(workc(i)) end do denr = ddot(n,z(1,j),1,workd,1) denr = denr+ddot(n,z(1,j+1),1,workd(n+1),1) deni = ddot(n,z(1,j),1,workd(n+1),1) deni = deni - ddot(n,z(1,j+1),1,workd,1) c c %----------------% c | Compute (x'*x) | c %----------------% c numr = dlapy2( dnrm2(n, z(1,j), 1), & dnrm2(n, z(1, j+1), 1) )**2 c c %----------------------------------------% c | Compute (x'x) / (x'*inv(A-sigma*M)*Mx) | c %----------------------------------------% c dmdul = dlapy2(denr,deni)**2 if ( dmdul .ge. safmin ) then dr(j) = sigmar+numr*denr / dmdul di(j) = sigmai-numr*deni / dmdul first = .false. else c c %---------------------% c | dmdul is too small. | c | Exit to avoid | c | overflow. | c %---------------------% c info = -15 go to 9000 c end if c else c c %---------------------------% c | Get the second eigenvalue | c | of the conjugate pair by | c | taking the conjugate of | c | previous one. | c %---------------------------% c dr(j) = dr(j-1) di(j) = -di(j-1) first = .true. c end if c 270 continue c else if ( type .eq. 2 .or. type .eq. 5) then c first = .true. do 280 j = 1, iparam(5) c c %----------------------------------% c | Use Rayleigh Quotient to recover | c | eigenvalues of the original | c | standard eigenvalue problem. | c %----------------------------------% c if ( di(j) .eq. zero ) then c c %-------------------------------------% c | Eigenvalue is real. Compute | c | d = (x'*inv[A-sigma*I]*x) / (x'*x). | c %-------------------------------------% c do i = 1, n workc(i) = dcmplx(z(i,j)) end do call zgbtrs ('Notranspose', n, kl, ku, 1, $ cfac, lda, iwork, workc, n, info) do i = 1, n workd(i) = dble(workc(i)) workd(i+n) = dimag(workc(i)) end do denr = ddot(n,z(1,j),1,workd,1) deni = ddot(n,z(1,j),1,workd(n+1),1) numr = dnrm2(n, z(1,j), 1)**2 dmdul = dlapy2(denr,deni)**2 if ( dmdul .ge. safmin ) then dr(j) = sigmar + numr*denr / dmdul else c c %---------------------% c | dmdul is too small. | c | Exit to avoid | c | overflow. | c %---------------------% c info = -15 go to 9000 c end if c else if (first) then c c %------------------------% c | Eigenvalue is complex. | c | Compute the first one | c | of the conjugate pair. | c %------------------------% c do i = 1, n workc(i) = dcmplx( z(i,j), z(i,j+1) ) end do c c %---------------------------% c | Compute inv[A-sigma*I]*x. | c %---------------------------% c call zgbtrs('Notranspose',n,kl,ku,1,cfac, $ lda, iwork, workc, n, info) c c %-----------------------------% c | Compute x'*inv(A-sigma*I)*x | c %-----------------------------% c do i = 1, n workd(i) = dble(workc(i)) workd(i+n) = dimag(workc(i)) end do denr = ddot(n,z(1,j),1,workd,1) denr = denr+ddot(n,z(1,j+1),1,workd(n+1),1) deni = ddot(n,z(1,j),1,workd(n+1),1) deni = deni - ddot(n,z(1,j+1),1,workd,1) c c %----------------% c | Compute (x'*x) | c %----------------% c numr = dlapy2( dnrm2(n, z(1,j), 1), & dnrm2(n, z(1,j+1), 1))**2 c c %----------------------------------------% c | Compute (x'x) / (x'*inv(A-sigma*I)*x). | c %----------------------------------------% c dmdul = dlapy2(denr,deni)**2 if (dmdul .ge. safmin) then dr(j) = sigmar+numr*denr / dmdul di(j) = sigmai-numr*deni / dmdul first = .false. else c c %---------------------% c | dmdul is too small. | c | Exit to avoid | c | overflow. | c %---------------------% c info = -15 go to 9000 end if c else c c %---------------------------% c | Get the second eigenvalue | c | of the conjugate pair by | c | taking the conjugate of | c | previous one. | c %---------------------------% c dr(j) = dr(j-1) di(j) = -di(j-1) first = .true. c end if c 280 continue c end if c end if c end if c end if c go to 9000 c end if c c %----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %----------------------------------------% c go to 90 c 9000 continue c end arpack-akloeckner-07/EXAMPLES/BAND/snband.f0000644000175000017500000014511007172770664020053 0ustar andreasandreasc \BeginDoc c c \Name: snband c c \Description: c c This subroutine returns the converged approximations to eigenvalues c of A*z = lambda*B*z and (optionally): c c (1) The corresponding approximate eigenvectors; c c (2) An orthonormal basis for the associated approximate c invariant subspace; c c (3) Both. c c Matrices A and B are stored in LAPACK-style banded form. c c There is negligible additional cost to obtain eigenvectors. An orthonormal c basis is always computed. There is an additional storage cost of n*nev c if both are requested (in this case a separate array Z must be supplied). c c The approximate eigenvalues and vectors are commonly called Ritz c values and Ritz vectors respectively. They are referred to as such c in the comments that follow. The computed orthonormal basis for the c invariant subspace corresponding to these Ritz values is referred to as a c Schur basis. c c snband can be called with one of the following modes: c c Mode 1: A*z = lambda*z. c ===> OP = A and B = I. c c Mode 2: A*z = lambda*M*z, M symmetric positive definite c ===> OP = inv[M]*A and B = M. c c Mode 3: A*z = lambda*M*z, M symmetric semi-definite c ===> OP = Real_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*z = amu*z, then c amu = 1/2 * [ 1/(lambda-sigma) + 1/(lambda-conjg(sigma)) ]. c Note: If sigma is real, i.e. imaginary part of sigma is zero; c Real_Part{ inv[A - sigma*M]*M } == inv[A - sigma*M]*M c amu == 1/(lambda-sigma). c c Mode 4: A*z = lambda*M*z, M symmetric semi-definite c ===> OP = Imaginary_Part{ inv[A - sigma*M]*M } and B = M. c ===> shift-and-invert mode (in real arithmetic) c If OP*z = amu*z, then c amu = 1/2i * [ 1/(lambda-sigma) - 1/(lambda-conjg(sigma)) ]. c c c The choice of mode must be specified in IPARAM(7) defined below. c c \Usage c call snband c ( RVEC, HOWMNY, SELECT, DR, DI, Z, LDZ, SIGMAR, SIGMAI, c WORKEV, V, N, AB, MB, LDA, RFAC, CFAC, KL, KU, WHICH, c BMAT, NEV, TOL, RESID, NCV, V, LDV, IPARAM, WORKD, c WORKL, LWORKL, WORKC, IWORK, INFO ) c c \Arguments c c RVEC LOGICAL (INPUT) c Specifies whether a basis for the invariant subspace corresponding c to the converged Ritz value approximations for the eigenproblem c A*z = lambda*B*z is computed. c c RVEC = .FALSE. Compute Ritz values only. c c RVEC = .TRUE. Compute the Ritz vectors or Schur vectors. c See Remarks below. c c HOWMNY Character*1 (INPUT) c Specifies the form of the basis for the invariant subspace c corresponding to the converged Ritz values that is to be computed. c c = 'A': Compute NEV Ritz vectors; c = 'P': Compute NEV Schur vectors; c = 'S': compute some of the Ritz vectors, specified c by the logical array SELECT. c c SELECT Logical array of dimension NCV. (INPUT) c If HOWMNY = 'S', SELECT specifies the Ritz vectors to be c computed. To select the Ritz vector corresponding to a c Ritz value (DR(j), DI(j)), SELECT(j) must be set to .TRUE.. c If HOWMNY = 'A' or 'P', SELECT is used as internal workspace. c c DR Real array of dimension NEV+1. (OUTPUT) c On exit, DR contains the real part of the Ritz value approximations c to the eigenvalues of A*z = lambda*B*z. c c DI Real array of dimension NEV+1. (OUTPUT) c On exit, DI contains the imaginary part of the Ritz value c approximations to the eigenvalues of A*z = lambda*B*z associated c with DR. c c NOTE: When Ritz values are complex, they will come in complex c conjugate pairs. If eigenvectors are requested, the c corresponding Ritz vectors will also come in conjugate c pairs and the real and imaginary parts of these are c represented in two consecutive columns of the array Z c (see below). c c Z Real N by NEV+1 array if RVEC = .TRUE. and HOWMNY = 'A'. (OUTPUT) c On exit, c if RVEC = .TRUE. and HOWMNY = 'A', then the columns of c Z represent approximate eigenvectors (Ritz vectors) corresponding c to the NCONV=IPARAM(5) Ritz values for eigensystem c A*z = lambda*B*z computed by SNAUPD. c c The complex Ritz vector associated with the Ritz value c with positive imaginary part is stored in two consecutive c columns. The first column holds the real part of the Ritz c vector and the second column holds the imaginary part. The c Ritz vector associated with the Ritz value with negative c imaginary part is simply the complex conjugate of the Ritz vector c associated with the positive imaginary part. c c If RVEC = .FALSE. or HOWMNY = 'P', then Z is not referenced. c c NOTE: If if RVEC = .TRUE. and a Schur basis is not required, c the array Z may be set equal to first NEV+1 columns of the Arnoldi c basis array V computed by SNAUPD. In this case the Arnoldi basis c will be destroyed and overwritten with the eigenvector basis. c c LDZ Integer. (INPUT) c The leading dimension of the array Z. If Ritz vectors are c desired, then LDZ >= max( 1, N ). In any case, LDZ >= 1. c c SIGMAR Real (INPUT) c If IPARAM(7) = 3 or 4, represents the real part of the shift. c Not referenced if IPARAM(7) = 1 or 2. c c SIGMAI Real (INPUT) c If IPARAM(7) = 3 or 4, represents the imaginary part of the c shift. c Not referenced if IPARAM(7) = 1 or 2. c c WORKEV Real work array of dimension 3*NCV. (WORKSPACE) c c N Integer. (INPUT) c Dimension of the eigenproblem. c c AB Real array of dimension LDA by N. (INPUT) c The matrix A in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of A is stored in the j-th column of the c array AB as follows: c AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c c MB Real array of dimension LDA by N. (INPUT) c The matrix M in band storage, in rows KL+1 to c 2*KL+KU+1; rows 1 to KL of the array need not be set. c The j-th column of M is stored in the j-th column of the c array AB as follows: c MB(kl+ku+1+i-j,j) = M(i,j) for max(1,j-ku)<=i<=min(m,j+kl) c Not referenced if IPARAM(7) = 1 c c LDA Integer. (INPUT) c Leading dimension of AB, MB, RFAC and CFAC. c c RFAC Real array of LDA by N. (WORKSPACE/OUTPUT) c RFAC is used to store the LU factors of MB when IPARAM(7) = 2 c is invoked. It is used to store the LU factors of c (A-sigma*M) when IPARAM(7) = 3 is invoked with a real shift. c It is not referenced when IPARAM(7) = 1 or 4. c c CFAC Complex array of LDA by N. (WORKSPACE/OUTPUT) c CFAC is used to store (A-SIGMA*M) and its LU factors c when IPARAM(7) = 3 or 4 are used with a complex shift SIGMA. c On exit, it contains the LU factors of (A-SIGMA*M). c It is not referenced when IPARAM(7) = 1 or 2. c c KL Integer. (INPUT) c Max(number of subdiagonals of A, number of subdiagonals of M) c c KU Integer. (OUTPUT) c Max(number of superdiagonals of A, number of superdiagonals of M) c c WHICH Character*2. (INPUT) c When IPARAM(7)= 1 or 2, WHICH can be set to any one of c the following. c c 'LM' -> want the NEV eigenvalues of largest magnitude. c 'SM' -> want the NEV eigenvalues of smallest magnitude. c 'LR' -> want the NEV eigenvalues of largest real part. c 'SR' -> want the NEV eigenvalues of smallest real part. c 'LI' -> want the NEV eigenvalues of largest imaginary part. c 'SI' -> want the NEV eigenvalues of smallest imaginary part. c c When IPARAM(7) = 3 or 4, WHICH should be set to 'LM' only. c c BMAT Character*1. (INPUT) c BMAT specifies the type of the matrix B that defines the c semi-inner product for the operator OP. c BMAT = 'I' -> standard eigenvalue problem A*z = lambda*z c BMAT = 'G' -> generalized eigenvalue problem A*z = lambda*M*z c NEV Integer. (INPUT) c Number of eigenvalues to be computed. c c TOL Real scalar. (INPUT) c Stopping criteria: the relative accuracy of the Ritz value c is considered acceptable if BOUNDS(I) .LE. TOL*ABS(RITZ(I)). c If TOL .LE. 0. is passed a default is set: c DEFAULT = SLAMCH('EPS') (machine precision as computed c by the LAPACK auxiliary subroutine SLAMCH). c c RESID Real array of length N. (INPUT/OUTPUT) c On INPUT: c If INFO .EQ. 0, a random initial residual vector is used. c If INFO .NE. 0, RESID contains the initial residual vector, c possibly from a previous run. c On OUTPUT: c RESID contains the final residual vector. c c NCV Integer. (INPUT) c Number of columns of the matrix V (less than or equal to N). c Represents the dimension of the Arnoldi basis constructed c by snaupd for OP. c c V Real array N by NCV+1. (OUTPUT) c Upon OUTPUT: If RVEC = .TRUE. the first NCONV=IPARAM(5) columns c represent approximate Schur vectors that span the c desired invariant subspace. c NOTE: The array Z may be set equal to first NEV+1 columns of the c Arnoldi basis vector array V computed by SNAUPD. In this case c if RVEC = .TRUE. and HOWMNY='A', then the first NCONV=IPARAM(5) c are the desired Ritz vectors. c c LDV Integer. (INPUT) c Leading dimension of V exactly as declared in the calling c program. c c IPARAM Integer array of length 11. (INPUT/OUTPUT) c IPARAM(1) = ISHIFT: c The shifts selected at each iteration are used to restart c the Arnoldi iteration in an implicit fashion. c It is set to 1 in this subroutine. The user do not need c to set this parameter. c ---------------------------------------------------------- c ISHIFT = 1: exact shift with respect to the current c Hessenberg matrix H. This is equivalent to c restarting the iteration from the beginning c after updating the starting vector with a linear c combination of Ritz vectors associated with the c "wanted" eigenvalues. c ------------------------------------------------------------- c c IPARAM(2) = No longer referenced. c c IPARAM(3) = MXITER c On INPUT: max number of Arnoldi update iterations allowed. c On OUTPUT: actual number of Arnoldi update iterations taken. c c IPARAM(4) = NB: blocksize to be used in the recurrence. c The code currently works only for NB = 1. c c IPARAM(5) = NCONV: number of "converged" eigenvalues. c c IPARAM(6) = IUPD c Not referenced. Implicit restarting is ALWAYS used. c c IPARAM(7) = IPARAM(7): c On INPUT determines what type of eigenproblem is being solved. c Must be 1,2,3,4; See under \Description of snband for the c four modes available. c c IPARAM(9) = NUMOP, IPARAM(10) = NUMOPB, IPARAM(11) = NUMREO, c OUTPUT: NUMOP = total number of OP*z operations, c NUMOPB = total number of B*z operations if BMAT='G', c NUMREO = total number of steps of re-orthogonalization. c c WORKD Real work array of length at least 3*n. (WORKSPACE) c c WORKL Real work array of length LWORKL. (WORKSPACE) c c LWORKL Integer. (INPUT) c LWORKL must be at least 3*NCV**2 + 6*NCV. c c WORKC Complex array of length N. (WORKSPACE) c Workspace used when IPARAM(7) = 3 or 4 for storing a temporary c complex vector. c c IWORK Integer array of dimension at least N. (WORKSPACE) c Used when IPARAM(7)=2,3,4 to store the pivot information in the c factorization of M or (A-SIGMA*M). c c INFO Integer. (INPUT/OUTPUT) c Error flag on output. c = 0: Normal exit. c = 1: The Schur form computed by LAPACK routine slahqr c could not be reordered by LAPACK routine strsen. c Re-enter subroutine SNEUPD with IPARAM(5)=NCV and c increase the size of the arrays DR and DI to have c dimension at least NCV and allocate at least NCV c columns for Z. NOTE: Not necessary if Z and V share c the same space. Please notify the authors. c c = -1: N must be positive. c = -2: NEV must be positive. c = -3: NCV-NEV >= 2 and less than or equal to N. c = -5: WHICH must be one of 'LM', 'SM', 'LR', 'SR', 'LI', 'SI' c = -6: BMAT must be one of 'I' or 'G'. c = -7: Length of private work WORKL array is not sufficient. c = -8: Error return from calculation of a real Schur form. c Informational error from LAPACK routine slahqr. c = -9: Error return from calculation of eigenvectors. c Informational error from LAPACK routine strevc. c = -10: IPARAM(7) must be 1,2,3,4. c = -11: IPARAM(7) = 1 and BMAT = 'G' are incompatible. c = -12: HOWMNY = 'S' not yet implemented c = -13: HOWMNY must be one of 'A' or 'P' c = -14: SNAUPD did not find any eigenvalues to sufficient c accuracy. c = -15: Overflow occurs when we try to transform the Ritz c values returned from SNAUPD to those of the original c problem using Rayleigh Quotient. c = -9999: Could not build an Arnoldi factorization. c IPARAM(5) returns the size of the current c Arnoldi factorization. c c \EndDoc c c------------------------------------------------------------------------ c c\BeginLib c c\References: c 1. D.C. Sorensen, "Implicit Application of Polynomial Filters in c a k-Step Arnoldi Method", SIAM J. Matr. Anal. Apps., 13 (1992), c pp 357-385. c c 2. R.B. Lehoucq, "Analysis and Implementation of an Implicitly c Restarted Arnoldi Iteration", Ph.D thesis, TR95-13, Rice Univ, c May 1995. c c\Routines called: c snaupd ARPACK reverse communication interface routine. c sneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgbtrf LAPACK band matrix factorization routine. c sgbtrs LAPACK band linear system solve routine. c cgbtrf LAPACK complex band matrix factorization routine. c cgbtrs LAPACK complex linear system solve routine. c slacpy LAPACK matrix copy routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c slamch LAPACK routine to compute the underflow threshold. c scopy Level 1 BLAS that copies one vector to another. c sdot Level 1 BLAS that computes the dot product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c sgbmv Level 2 BLAS that computes the band matrix vector product. c c\Remarks c c 1. Currently only HOWMNY = 'A' and 'P' are implemented. c c Let X' denote the transpose of X. c c 2. Schur vectors are an orthogonal representation for the basis of c Ritz vectors. Thus, their numerical properties are often superior. c If RVEC = .TRUE. then the relationship c A * V(:,1:IPARAM(5)) = V(:,1:IPARAM(5)) * T, and c V(:,1:IPARAM(5))' * V(:,1:IPARAM(5)) = I are approximately satisfied. c Here T is the leading submatrix of order IPARAM(5) of the real c upper quasi-triangular matrix stored workl(ipntr(12)). That is, c T is block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; c each 2-by-2 diagonal block has its diagonal elements equal and its c off-diagonal elements of opposite sign. Corresponding to each 2-by-2 c diagonal block is a complex conjugate pair of Ritz values. The real c Ritz values are stored on the diagonal of T. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nband.F SID: 2.3 DATE OF SID: 10/17/00 RELEASE: 2 c c\EndLib c c--------------------------------------------------------------------- c subroutine snband( rvec, howmny, select, dr, di, z, ldz, sigmar, & sigmai, workev, n, ab, mb, lda, rfac, cfac, kl, ku, & which, bmat, nev, tol, resid, ncv, v, ldv, & iparam, workd, workl, lworkl, workc, iwork, info) c c %------------------% c | Scalar Arguments | c %------------------% c character which*2, bmat, howmny integer n, lda, kl, ku, nev, ncv, ldv, & ldz, lworkl, info Real & tol, sigmar, sigmai c c %-----------------% c | Array Arguments | c %-----------------% c integer iparam(*), iwork(*) logical select(*) Real & dr(*), di(*), resid(*), v(ldv,*), z(ldz,*), & ab(lda,*), mb(lda,*), rfac(lda,*), & workd(*), workl(*), workev(*) Complex & cfac(lda,*), workc(*) c c %--------------% c | Local Arrays | c %--------------% c integer ipntr(14) c c %---------------% c | Local Scalars | c %---------------% c integer ido, i, j, type, imid, itop, ibot, ierr Real & numr, denr, deni, dmdul, safmin logical rvec, first c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c c %-----------------------------% c | LAPACK & BLAS routines used | c %-----------------------------% c Real & sdot, snrm2, slapy2, slamch external sdot, scopy, sgbmv, cgbtrf, cgbtrs, sgbtrf, & sgbtrs, snrm2, slapy2, slacpy, slamch c c %---------------------% c | Intrinsic Functions | c %---------------------% c Intrinsic real, aimag, cmplx c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------% c | safmin = safe minimum is such | c | that 1/sfmin does not overflow | c %--------------------------------% c safmin = slamch('safmin') c c %----------------------------------------------------------------% c | Set type of the problem to be solved. Check consistency | c | between BMAT and IPARAM(7). | c | type = 1 --> Solving standard problem in regular mode. | c | type = 2 --> Solving standard problem in shift-invert mode. | c | type = 3 --> Solving generalized problem in regular mode. | c | type = 4 --> Solving generalized problem in shift-invert mode. | c | type = 5 --> Solving standard problem in shift-invert mode | c | using iparam(7) = 4 in SNAUPD. | c | type = 6 --> Solving generalized problem in shift-invert mode. | c | using iparam(7) = 4 in SNAUPD. | c %----------------------------------------------------------------% c if ( iparam(7) .eq. 1 ) then type = 1 else if ( iparam(7) .eq. 3 .and. bmat .eq. 'I') then type = 2 else if ( iparam(7) .eq. 2 ) then type = 3 else if ( iparam(7) .eq. 3 .and. bmat .eq. 'G') then type = 4 else if ( iparam(7) .eq. 4 .and. bmat .eq. 'I') then type = 5 else if ( iparam(7) .eq. 4 .and. bmat .eq. 'G') then type = 6 else print*, ' ' print*, 'BMAT is inconsistent with IPARAM(7).' print*, ' ' go to 9000 end if c c %----------------------------------% c | When type = 5,6 are used, sigmai | c | must be nonzero. | c %----------------------------------% c if ( type .eq. 5 .or. type .eq. 6 ) then if ( sigmai .eq. zero ) then print*, ' ' print*, '_NBAND: sigmai must be nonzero when type 5 or 6 & is used. ' print*, ' ' go to 9000 end if end if c c %------------------------% c | Initialize the reverse | c | communication flag. | c %------------------------% c ido = 0 c c %----------------% c | Exact shift is | c | used. | c %----------------% c iparam(1) = 1 c c %-----------------------------------% c | Both matrices A and M are stored | c | between rows itop and ibot. Imid | c | is the index of the row that | c | stores the diagonal elements. | c %-----------------------------------% c itop = kl + 1 imid = kl + ku + 1 ibot = 2*kl + ku + 1 c if ( type .eq. 2 .or. type .eq. 5 ) then c c %-------------------------------% c | Solving a standard eigenvalue | c | problem in shift-invert mode. | c | Factor (A-sigma*I). | c %-------------------------------% c if (sigmai .eq. zero) then c c %-----------------------------------% c | Construct (A-sigmar*I) and factor | c | in real arithmetic. | c %-----------------------------------% c call slacpy ('A', ibot, n, ab, lda, rfac, lda ) do 10 j = 1, n rfac(imid,j) = ab(imid,j) - sigmar 10 continue call sgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr ) if (ierr .ne. 0) then print*, ' ' print*, ' _NBAND: Error with _gbtrf. ' print*, ' ' go to 9000 end if c else c c %-----------------------------------% c | Construct (A-sigmar*I) and factor | c | in COMPLEX arithmetic. | c %-----------------------------------% c do 30 j = 1, n do 20 i = itop, ibot cfac(i,j) = cmplx(ab(i,j)) 20 continue 30 continue c do 40 j = 1, n cfac(imid,j) = cfac(imid,j) $ - cmplx(sigmar, sigmai) 40 continue c call cgbtrf(n, n, kl, ku, cfac, lda, iwork, ierr ) if ( ierr .ne. 0) then print*, ' ' print*, ' _NBAND: Error with _gbtrf. ' print*, ' ' go to 9000 end if c end if else if ( type .eq. 3 ) then c c %-----------------------------------------------% c | Solving generalized eigenvalue problem in | c | regular mode. Copy M to rfac, and call LAPACK | c | routine sgbtrf to factor M. | c %-----------------------------------------------% c call slacpy ('A', ibot, n, mb, lda, rfac, lda ) call sgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr) if (ierr .ne. 0) then print*, ' ' print*,'_NBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 .or. type .eq. 6 ) then c c %-------------------------------------------% c | Solving generalized eigenvalue problem in | c | shift-invert mode. | c %-------------------------------------------% c if ( sigmai .eq. zero ) then c c %--------------------------------------------% c | Construct (A - sigma*M) and factor in real | c | arithmetic. | c %--------------------------------------------% c do 60 j = 1,n do 50 i = itop, ibot rfac(i,j) = ab(i,j) - sigmar*mb(i,j) 50 continue 60 continue c call sgbtrf(n, n, kl, ku, rfac, lda, iwork, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_NBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c else c c %-----------------------------------------------% c | Construct (A - sigma*M) and factor in complex | c | arithmetic. | c %-----------------------------------------------% c do 80 j = 1,n do 70 i = itop, ibot cfac(i,j) = cmplx( ab(i,j)-sigmar*mb(i,j), & -sigmai*mb(i,j) ) 70 continue 80 continue c call cgbtrf(n, n, kl, ku, cfac, lda, iwork, ierr) if ( ierr .NE. 0 ) then print*, ' ' print*, '_NBAND: Error with _gbtrf.' print*, ' ' go to 9000 end if c end if c end if c c %--------------------------------------------% c | M A I N L O O P (reverse communication) | c %--------------------------------------------% c 90 continue c call snaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1) then c if ( type .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( type .eq. 2 ) then c if (sigmai .eq. zero) then c c %----------------------------------% c | Shift is real. Perform | c | y <--- OP*x = inv[A-sigmar*I]*x | c | to force the starting vector | c | into the range of OP. | c %----------------------------------% c call scopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _NBAND: Error with _bgtrs. ' print*, ' ' go to 9000 end if c else c c %--------------------------------------------% c | Shift is COMPLEX. Perform | c | y <--- OP*x = Real_Part{inv[A-sigma*I]*x} | c | to force the starting vector into the | c | range of OP. | c %--------------------------------------------% c do 100 j = 1, n workc(j) = cmplx(workd(ipntr(1)+j-1)) 100 continue c call cgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _NBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c do 110 j = 1, n workd(ipntr(2)+j-1) = real(workc(j)) 110 continue c end if c else if ( type .eq. 3 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c | to force the starting vector into | c | the range of OP. | c %-----------------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _bgtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 ) then c c %-----------------------------------------% c | Perform y <-- OP*x | c | = Real_part{inv[A-SIGMA*M]*M}*x | c | to force the starting vector into the | c | range of OP. | c %-----------------------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c if ( sigmai .eq. zero ) then c c %---------------------% c | Shift is real, stay | c | in real arithmetic. | c %---------------------% c call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else c c %--------------------------% c | Goto complex arithmetic. | c %--------------------------% c do 120 i = 1,n workc(i) = cmplx(workd(ipntr(2)+i-1)) 120 continue c call cgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c do 130 i = 1, n workd(ipntr(2)+i-1) = real(workc(i)) 130 continue c end if c else if ( type .eq. 5) then c c %---------------------------------------% c | Perform y <-- OP*x | c | = Imaginary_part{inv[A-SIGMA*I]}*x | c | to force the starting vector into the | c | range of OP. | c %---------------------------------------% c do 140 j = 1, n workc(j) = cmplx(workd(ipntr(1)+j-1)) 140 continue c call cgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _NBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c do 150 j = 1, n workd(ipntr(2)+j-1) = aimag(workc(j)) 150 continue c else if ( type .eq. 6 ) then c c %----------------------------------------% c | Perform y <-- OP*x | c | Imaginary_part{inv[A-SIGMA*M]*M} | c | to force the starting vector into the | c | range of OP. | c %----------------------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c do 160 i = 1,n workc(i) = cmplx(workd(ipntr(2)+i-1)) 160 continue c call cgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c do 170 i = 1, n workd(ipntr(2)+i-1) = aimag(workc(i)) 170 continue c end if c else if (ido .eq. 1) then c if ( type .eq. 1) then c c %----------------------------% c | Perform y <--- OP*x = A*x | c %----------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else if ( type .eq. 2) then c if ( sigmai .eq. zero) then c c %----------------------------------% c | Shift is real. Perform | c | y <--- OP*x = inv[A-sigmar*I]*x. | c %----------------------------------% c call scopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) else c c %------------------------------------------% c | Shift is COMPLEX. Perform | c | y <-- OP*x = Real_Part{inv[A-sigma*I]*x} | c | in COMPLEX arithmetic. | c %------------------------------------------% c do 180 j = 1, n workc(j) = cmplx(workd(ipntr(1)+j-1)) 180 continue c call cgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c do 190 j = 1, n workd(ipntr(2)+j-1) = real(workc(j)) 190 continue c end if c else if ( type .eq. 3 ) then c c %-----------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c %-----------------------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, ab(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _bgtrs.' print*, ' ' go to 9000 end if c else if ( type .eq. 4 ) then c c %--------------------------------------% c | Perform y <-- inv(A-sigma*M)*(M*x). | c | (M*x) has been computed and stored | c | in workd(ipntr(3)). | c %--------------------------------------% c if ( sigmai .eq. zero ) then c c %------------------------% c | Shift is real, stay in | c | real arithmetic. | c %------------------------% c call scopy(n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call sgbtrs ('Notranspose', n, kl, ku, 1, rfac, lda, & iwork, workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c else c c %---------------------------% c | Go to COMPLEX arithmetic. | c %---------------------------% c do 200 i = 1,n workc(i) = cmplx(workd(ipntr(3)+i-1)) 200 continue c call cgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error in _gbtrs.' print*, ' ' go to 9000 end if c do 210 i = 1,n workd(ipntr(2)+i-1) = real(workc(i)) 210 continue c end if c else if ( type .eq. 5 ) then c c %---------------------------------------% c | Perform y <-- OP*x | c | = Imaginary_part{inv[A-SIGMA*I]*x} | c %---------------------------------------% c do 220 j = 1, n workc(j) = cmplx(workd(ipntr(1)+j-1)) 220 continue c call cgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' _NBAND: Error with _gbtrs. ' print*, ' ' go to 9000 end if c do 230 j = 1, n workd(ipntr(2)+j-1) = aimag(workc(j)) 230 continue c else if ( type .eq. 6) then c c %-----------------------------------------% c | Perform y <-- OP*x | c | = Imaginary_part{inv[A-SIGMA*M]*M}*x. | c %-----------------------------------------% c do 240 i = 1,n workc(i) = cmplx(workd(ipntr(3)+i-1)) 240 continue c call cgbtrs ('Notranspose', n, kl, ku, 1, cfac, lda, & iwork, workc, n, ierr) if (ierr .ne. 0) then print*, ' ' print*, '_NBAND: Error with _gbtrs.' print*, ' ' go to 9000 end if c do 250 i = 1, n workd(ipntr(2)+i-1) = aimag(workc(i)) 250 continue c end if c else if (ido .eq. 2) then c c %--------------------% c | Perform y <-- M*x | c | Not used when | c | type = 1,2. | c %--------------------% c call sgbmv('Notranspose', n, n, kl, ku, one, mb(itop,1), & lda, workd(ipntr(1)), 1, zero, & workd(ipntr(2)), 1) c else c c %-----------------------------------------% c | Either we have convergence, or there is | c | error. | c %-----------------------------------------% c if ( info .lt. 0) then c c %--------------------------% c | Error message, check the | c | documentation in SNAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _naupd info = ',info print *, ' Check the documentation of _naupd ' print *, ' ' go to 9000 c else c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c if (iparam(5) .gt. 0) then c call sneupd ( rvec, 'A', select, dr, di, z, ldz, & sigmar, sigmai, workev, bmat, n, which, & nev, tol, resid, ncv, v, ldv, iparam, & ipntr, workd, workl, lworkl, info ) c if ( info .ne. 0) then c c %------------------------------------% c | Check the documentation of SNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd = ', info print *, ' Check the documentation of _neupd ' print *, ' ' go to 9000 c else if ( sigmai .ne. zero ) then c if ( type .eq. 4 .or. type .eq. 6 ) then c first = .true. do 270 j = 1, iparam(5) c c %----------------------------------% c | Use Rayleigh Quotient to recover | c | eigenvalues of the original | c | generalized eigenvalue problem. | c %----------------------------------% c if ( di(j) .eq. zero ) then c c %--------------------------------------% c | Eigenvalue is real. Compute | c | d = (x'*inv[A-sigma*M]*M*x) / (x'*x) | c %--------------------------------------% c call sgbmv('Nontranspose', n, n, kl, ku, one, $ mb(itop,1), lda, z(1,j), 1, zero, $ workd, 1) do i = 1, n workc(i) = cmplx(workd(i)) end do call cgbtrs ('Notranspose', n, kl, ku, 1, $ cfac, lda, iwork, workc, n, info) do i = 1, n workd(i) = real(workc(i)) workd(i+n) = aimag(workc(i)) end do denr = sdot(n, z(1,j), 1, workd, 1) deni = sdot(n, z(1,j), 1, workd(n+1), 1) numr = snrm2(n, z(1,j), 1)**2 dmdul = slapy2(denr,deni)**2 if ( dmdul .ge. safmin ) then dr(j) = sigmar + numr*denr / dmdul else c c %---------------------% c | dmdul is too small. | c | Exit to avoid | c | overflow. | c %---------------------% c info = -15 go to 9000 end if c else if (first) then c c %------------------------% c | Eigenvalue is complex. | c | Compute the first one | c | of the conjugate pair. | c %------------------------% c c %-------------% c | Compute M*x | c %-------------% c call sgbmv('Nontranspose', n, n, kl, ku, $ one, mb(itop,1), lda, z(1,j), 1, zero, $ workd, 1) call sgbmv('Nontranspose', n, n, kl, ku, $ one, mb(itop,1), lda, z(1,j+1), 1, $ zero, workd(n+1), 1) do i = 1, n workc(i) = cmplx(workd(i),workd(i+n)) end do c c %----------------------------% c | Compute inv(A-sigma*M)*M*x | c %----------------------------% c call cgbtrs('Notranspose',n,kl,ku,1,cfac, $ lda, iwork, workc, n, info) c c %-------------------------------% c | Compute x'*inv(A-sigma*M)*M*x | c %-------------------------------% c do i = 1, n workd(i) = real(workc(i)) workd(i+n) = aimag(workc(i)) end do denr = sdot(n,z(1,j),1,workd,1) denr = denr+sdot(n,z(1,j+1),1,workd(n+1),1) deni = sdot(n,z(1,j),1,workd(n+1),1) deni = deni - sdot(n,z(1,j+1),1,workd,1) c c %----------------% c | Compute (x'*x) | c %----------------% c numr = slapy2( snrm2(n, z(1,j), 1), & snrm2(n, z(1, j+1), 1) )**2 c c %----------------------------------------% c | Compute (x'x) / (x'*inv(A-sigma*M)*Mx) | c %----------------------------------------% c dmdul = slapy2(denr,deni)**2 if ( dmdul .ge. safmin ) then dr(j) = sigmar+numr*denr / dmdul di(j) = sigmai-numr*deni / dmdul first = .false. else c c %---------------------% c | dmdul is too small. | c | Exit to avoid | c | overflow. | c %---------------------% c info = -15 go to 9000 c end if c else c c %---------------------------% c | Get the second eigenvalue | c | of the conjugate pair by | c | taking the conjugate of | c | previous one. | c %---------------------------% c dr(j) = dr(j-1) di(j) = -di(j-1) first = .true. c end if c 270 continue c else if ( type .eq. 2 .or. type .eq. 5) then c first = .true. do 280 j = 1, iparam(5) c c %----------------------------------% c | Use Rayleigh Quotient to recover | c | eigenvalues of the original | c | standard eigenvalue problem. | c %----------------------------------% c if ( di(j) .eq. zero ) then c c %-------------------------------------% c | Eigenvalue is real. Compute | c | d = (x'*inv[A-sigma*I]*x) / (x'*x). | c %-------------------------------------% c do i = 1, n workc(i) = cmplx(z(i,j)) end do call cgbtrs ('Notranspose', n, kl, ku, 1, $ cfac, lda, iwork, workc, n, info) do i = 1, n workd(i) = real(workc(i)) workd(i+n) = aimag(workc(i)) end do denr = sdot(n,z(1,j),1,workd,1) deni = sdot(n,z(1,j),1,workd(n+1),1) numr = snrm2(n, z(1,j), 1)**2 dmdul = slapy2(denr,deni)**2 if ( dmdul .ge. safmin ) then dr(j) = sigmar + numr*denr / dmdul else c c %---------------------% c | dmdul is too small. | c | Exit to avoid | c | overflow. | c %---------------------% c info = -15 go to 9000 c end if c else if (first) then c c %------------------------% c | Eigenvalue is complex. | c | Compute the first one | c | of the conjugate pair. | c %------------------------% c do i = 1, n workc(i) = cmplx( z(i,j), z(i,j+1) ) end do c c %---------------------------% c | Compute inv[A-sigma*I]*x. | c %---------------------------% c call cgbtrs('Notranspose',n,kl,ku,1,cfac, $ lda, iwork, workc, n, info) c c %-----------------------------% c | Compute x'*inv(A-sigma*I)*x | c %-----------------------------% c do i = 1, n workd(i) = real(workc(i)) workd(i+n) = aimag(workc(i)) end do denr = sdot(n,z(1,j),1,workd,1) denr = denr+sdot(n,z(1,j+1),1,workd(n+1),1) deni = sdot(n,z(1,j),1,workd(n+1),1) deni = deni - sdot(n,z(1,j+1),1,workd,1) c c %----------------% c | Compute (x'*x) | c %----------------% c numr = slapy2( snrm2(n, z(1,j), 1), & snrm2(n, z(1,j+1), 1))**2 c c %----------------------------------------% c | Compute (x'x) / (x'*inv(A-sigma*I)*x). | c %----------------------------------------% c dmdul = slapy2(denr,deni)**2 if (dmdul .ge. safmin) then dr(j) = sigmar+numr*denr / dmdul di(j) = sigmai-numr*deni / dmdul first = .false. else c c %---------------------% c | dmdul is too small. | c | Exit to avoid | c | overflow. | c %---------------------% c info = -15 go to 9000 end if c else c c %---------------------------% c | Get the second eigenvalue | c | of the conjugate pair by | c | taking the conjugate of | c | previous one. | c %---------------------------% c dr(j) = dr(j-1) di(j) = -di(j-1) first = .true. c end if c 280 continue c end if c end if c end if c end if c go to 9000 c end if c c %----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %----------------------------------------% c go to 90 c 9000 continue c end arpack-akloeckner-07/EXAMPLES/BAND/README0000644000175000017500000000457406053172537017317 0ustar andreasandreas1. Purpose ------- This directory contains example drivers that call subroutines [s,d]sband.f, [s,d]nband.f or [c,z]nband.f to solve various eigenvalue problems in which matrices have BANDED structure. These drivers illustrate how to construct LAPACK-style banded matrices, and how to set various ARPACK parameters to solve different problems in different modes. The user may modify any one of these drivers, and construct his/her own matrix to solve the problem of his/her own interest. 2. Naming convention ----------------- The name for each banded solver has the form 'XYband.f', where X - is 's' (single precision) or 'd' (double precision) or 'c' (single precision complex) or 'z' (double precision complex) Y - is 's' (symmetric) or 'n' (nonsymmetric) The name for each driver has the form 'XYbdrN.f', where X - is 's' (single precision) or 'd' (double precision) or 'c' (single precision complex) or 'z' (double precision complex) Y - is 's' (symmetric) or 'n' (nonsymmetric) N - is a number between 1 and 6. If N = 1, the driver solves a STANDARD eigenvalue problem in REGULAR mode. N = 2, the driver solves a STANDARD eigenvalue problem in SHIFT-INVERT mode. N = 3, the driver solves a GENERALIZED eigenvalue problem in INVERSE mode. N = 4, the driver solves a GENERALIZED eigenvalue problem in SHIFT-INVERT mode (using mode 3 of __aupd.) These are four commonly used drivers. When N > 4 (only for real matrices), a special mode is used. For symmetric problem, if N = 5, the driver solves a GENERALIZED eigenvalue problem in BUCKLING mode. N = 6, the driver solves a GENERALIZED eigenvalue problem in CAYLEY mode. For nonsymmetric problem, if N = 5, the driver solves a STANDARD eigenvalue problem in SHIFT-INVERT mode using mode 4 of [d,s]naupd.f. N = 6. the driver solves a GENERALIZED eigenvalue problem SHIFT-INVERT mode using mode 4 of [d,s]naupd.f. Note: the imaginary part of the shift MUST be nonzero when these two drivers are used. 3. Usage ----- To run these drivers, you may use the makefile in this directory and issue, for example, "make snbdr1". Then execute using "snbdr1". arpack-akloeckner-07/EXAMPLES/SIMPLE/0000755000175000017500000000000007174076776016727 5ustar andreasandreasarpack-akloeckner-07/EXAMPLES/SIMPLE/cnsimp.f0000644000175000017500000005060207174076744020365 0ustar andreasandreas program cnsimp c c This example program is intended to illustrate the c simplest case of using ARPACK in considerable detail. c This code may be used to understand basic usage of ARPACK c and as a template for creating an interface to ARPACK. c c This code shows how to use ARPACK to find a few eigenvalues c (lambda) and corresponding eigenvectors (x) for the standard c eigenvalue problem: c c A*x = lambda*x c c where A is a general n by n complex matrix. c c The main points illustrated here are c c 1) How to declare sufficient memory to find NEV c eigenvalues of largest magnitude. Other options c are available. c c 2) Illustration of the reverse communication interface c needed to utilize the top level ARPACK routine CNAUPD c that computes the quantities needed to construct c the desired eigenvalues and eigenvectors(if requested). c c 3) How to extract the desired eigenvalues and eigenvectors c using the ARPACK routine CNEUPD. c c The only thing that must be supplied in order to use this c routine on your problem is to change the array dimensions c appropriately, to specify WHICH eigenvalues you want to compute c and to supply a matrix-vector product c c w <- Av c c in place of the call to AV( ) below. c c c Once usage of this routine is understood, you may wish to explore c the other available options to improve convergence, to solve generalized c problems, etc. Look at the file ex-complex.doc in DOCUMENTS directory. c This codes implements c c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c ... OP = A and B = I. c ... Assume "call av (nx,x,y)" computes y = A*x c ... Use mode 1 of CNAUPD. c c\BeginLib c c\Routines called c cnaupd ARPACK reverse communication interface routine. c cneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c scnrm2 Level 1 BLAS that computes the norm of a complex vector. c caxpy Level 1 BLAS that computes y <- alpha*x+y. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nsimp.F SID: 2.4 DATE OF SID: 10/20/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c--------------------------------------------------------------------------- c c %------------------------------------------------------% c | Storage Declarations: | c | | c | The maximum dimensions for all arrays are | c | set here to accommodate a problem size of | c | N .le. MAXN | c | | c | NEV is the number of eigenvalues requested. | c | See specifications for ARPACK usage below. | c | | c | NCV is the largest number of basis vectors that will | c | be used in the Implicitly Restarted Arnoldi | c | Process. Work per major iteration is | c | proportional to N*NCV*NCV. | c | | c | You must set: | c | | c | MAXN: Maximum dimension of the A allowed. | c | MAXNEV: Maximum NEV allowed. | c | MAXNCV: Maximum NCV allowed. | c %------------------------------------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=12, maxncv=30, ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Complex & ax(maxn), d(maxncv), & v(ldv,maxncv), workd(3*maxn), & workev(2*maxncv), resid(maxn), & workl(3*maxncv*maxncv+5*maxncv) Real & rwork(maxncv), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nx, nev, ncv, lworkl, info, ierr, & j, ishfts, maxitr, mode1, nconv Complex & sigma Real & tol logical rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & scnrm2, slapy2 external scnrm2, caxpy, slapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The following include statement and assignments | c | initiate trace output from the internal | c | actions of ARPACK. See debug.doc in the | c | DOCUMENTS directory for usage. Initially, the | c | most useful information will be a breakdown of | c | time spent in the various stages of computation | c | given by setting mcaupd = 1 | c %-------------------------------------------------% c include 'debug.h' ndigit = -3 logfil = 6 mcaitr = 0 mcapps = 0 mcaupd = 1 mcaup2 = 0 mceigh = 0 mceupd = 0 c c %-------------------------------------------------% c | The following sets dimensions for this problem. | c %-------------------------------------------------% c nx = 10 n = nx*nx c c %-----------------------------------------------% c | | c | Specifications for ARPACK usage are set | c | below: | c | | c | 1) NEV = 4 asks for 4 eigenvalues to be | c | computed. | c | | c | 2) NCV = 20 sets the length of the Arnoldi | c | factorization | c | | c | 3) This is a standard problem | c | (indicated by bmat = 'I') | c | | c | 4) Ask for the NEV eigenvalues of | c | largest magnitude | c | (indicated by which = 'LM') | c | See documentation in CNAUPD for the | c | other options SM, LR, SR, LI, SI. | c | | c | Note: NEV and NCV must satisfy the following | c | conditions: | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c | | c %-----------------------------------------------% c nev = 4 ncv = 20 bmat = 'I' which = 'LM' c if ( n .gt. maxn ) then print *, ' ERROR with _NSIMP: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NSIMP: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NSIMP: NCV is greater than MAXNCV ' go to 9000 end if c c %-----------------------------------------------------% c | | c | Specification of stopping rules and initial | c | conditions before calling CNAUPD | c | | c | TOL determines the stopping criterion. | c | | c | Expect | c | abs(lambdaC - lambdaT) < TOL*abs(lambdaC) | c | computed true | c | | c | If TOL .le. 0, then TOL <- macheps | c | (machine precision) is used. | c | | c | IDO is the REVERSE COMMUNICATION parameter | c | used to specify actions to be taken on return | c | from CNAUPD. (see usage below) | c | | c | It MUST initially be set to 0 before the first | c | call to CNAUPD. | c | | c | INFO on entry specifies starting vector information | c | and on return indicates error codes | c | | c | Initially, setting INFO=0 indicates that a | c | random starting vector is requested to | c | start the ARNOLDI iteration. Setting INFO to | c | a nonzero value on the initial call is used | c | if you want to specify your own starting | c | vector (This vector must be placed in RESID). | c | | c | The work array WORKL is used in CNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. | c | | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | Specification of Algorithm Mode: | c | | c | This program uses the exact shift strategy | c | (indicated by setting IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of CNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | CNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode1 = 1 c iparam(1) = ishfts c iparam(3) = maxitr c iparam(7) = mode1 c c %------------------------------------------------% c | M A I N L O O P (Reverse Communication Loop) | c %------------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine CNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% call cnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork,info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform matrix vector multiplication | c | | c | y <--- A*x | c | | c | The user should supply his/her own | c | matrix vector multiplication routine here | c | that takes workd(ipntr(1)) as the input | c | vector x , and returns the resulting | c | matrix-vector product y = A*x in the | c | array workd(ipntr(2)). | c %-------------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call CNAUPD again. | c %-----------------------------------------% c go to 10 c endif c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in CNAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using CNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may be also computed now if | c | desired. (indicated by rvec = .true.) | c | | c | The routine CNEUPD now called to do this | c | post processing (Other modes may require | c | more complicated post processing than | c | mode1.) | c | | c %-------------------------------------------% c rvec = .true. c call cneupd (rvec, 'A', select, D, V, ldv, sigma, & workev, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork, ierr) c c %-----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D and the corresponding | c | eigenvectors are returned in the first | c | NCONV (=IPARAM(5)) columns of the two | c | dimensional array V if requested. Otherwise, | c | an orthogonal basis for the invariant | c | subspace corresponding to the eigenvalues in | c | D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of CNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(nx, v(1,j), ax) call caxpy(n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = real (d(j)) rd(j,2) = aimag(d(j)) rd(j,3) = scnrm2(n, ax, 1) rd(j,3) = rd(j,3) / slapy2(rd(j,1),rd(j,2)) 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and relative residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NSIMP ' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program cnsimp. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector subroutine c c The matrix used is the convection-diffusion operator c discretized using centered difference. c subroutine av (nx, v, w) integer nx, j, lo Complex & v(nx*nx), w(nx*nx), one, h2 parameter (one = (1.0E+0, 0.0E+0) ) external caxpy c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c derived from the standard central difference discretization c of the 2-dimensional convection-diffusion operator c (Laplacian u) + rho*(du/dx) c on the unit squqre with zero boundary condition. c c The subroutine TV is called to computed y<---T*x. c c h2 = one / cmplx((nx+1)*(nx+1)) c call tv(nx,v(1),w(1)) call caxpy(nx, -one/h2, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call caxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) call caxpy(nx, -one/h2, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call caxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) c return end c========================================================================= subroutine tv (nx, x, y) c integer nx, j Complex & x(nx), y(nx), h, h2, dd, dl, du c Complex & one, rho parameter (one = (1.0E+0, 0.0E+0) , & rho = (1.0E+2, 0.0E+0) ) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal c h = one / cmplx(nx+1) h2 = h*h dd = (4.0E+0, 0.0E+0) / h2 dl = -one/h2 - (5.0E-1, 0.0E+0) *rho/h du = -one/h2 + (5.0E-1, 0.0E+0) *rho/h c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/SIMPLE/dnsimp.f0000644000175000017500000005364207172773454020375 0ustar andreasandreas program dnsimp c c c This example program is intended to illustrate the c simplest case of using ARPACK in considerable detail. c This code may be used to understand basic usage of ARPACK c and as a template for creating an interface to ARPACK. c c This code shows how to use ARPACK to find a few eigenvalues c (lambda) and corresponding eigenvectors (x) for the standard c eigenvalue problem: c c A*x = lambda*x c c where A is a n by n real nonsymmetric matrix. c c The main points illustrated here are c c 1) How to declare sufficient memory to find NEV c eigenvalues of largest magnitude. Other options c are available. c c 2) Illustration of the reverse communication interface c needed to utilize the top level ARPACK routine DNAUPD c that computes the quantities needed to construct c the desired eigenvalues and eigenvectors(if requested). c c 3) How to extract the desired eigenvalues and eigenvectors c using the ARPACK routine DNEUPD. c c The only thing that must be supplied in order to use this c routine on your problem is to change the array dimensions c appropriately, to specify WHICH eigenvalues you want to compute c and to supply a matrix-vector product c c w <- Av c c in place of the call to AV( ) below. c c Once usage of this routine is understood, you may wish to explore c the other available options to improve convergence, to solve generalized c problems, etc. Look at the file ex-nonsym.doc in DOCUMENTS directory. c This codes implements c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is obtained from the standard central difference c discretization of the convection-diffusion operator c (Laplacian u) + rho*(du / dx) c on the unit square, with zero Dirichlet boundary condition. c c ... OP = A and B = I. c ... Assume "call av (nx,x,y)" computes y = A*x c ... Use mode 1 of DNAUPD. c c\BeginLib c c\Routines called: c dnaupd ARPACK reverse communication interface routine. c dneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nsimp.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c--------------------------------------------------------------------------- c c %------------------------------------------------------% c | Storage Declarations: | c | | c | The maximum dimensions for all arrays are | c | set here to accommodate a problem size of | c | N .le. MAXN | c | | c | NEV is the number of eigenvalues requested. | c | See specifications for ARPACK usage below. | c | | c | NCV is the largest number of basis vectors that will | c | be used in the Implicitly Restarted Arnoldi | c | Process. Work per major iteration is | c | proportional to N*NCV*NCV. | c | | c | You must set: | c | | c | MAXN: Maximum dimension of the A allowed. | c | MAXNEV: Maximum NEV allowed. | c | MAXNCV: Maximum NCV allowed. | c %------------------------------------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=12, maxncv=30, ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Double precision & ax(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nx, nev, ncv, lworkl, info, ierr, & j, ishfts, maxitr, mode1, nconv Double precision & tol, sigmar, sigmai logical first, rvec c c %------------% c | Parameters | c %------------% c Double precision & zero parameter (zero = 0.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2, dnrm2 external dlapy2, dnrm2, daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The following include statement and assignments | c | initiate trace output from the internal | c | actions of ARPACK. See debug.doc in the | c | DOCUMENTS directory for usage. Initially, the | c | most useful information will be a breakdown of | c | time spent in the various stages of computation | c | given by setting mnaupd = 1. | c %-------------------------------------------------% c include 'debug.h' ndigit = -3 logfil = 6 mnaitr = 0 mnapps = 0 mnaupd = 1 mnaup2 = 0 mneigh = 0 mneupd = 0 c c %-------------------------------------------------% c | The following sets dimensions for this problem. | c %-------------------------------------------------% c nx = 10 n = nx*nx c c %-----------------------------------------------% c | | c | Specifications for ARPACK usage are set | c | below: | c | | c | 1) NEV = 4 asks for 4 eigenvalues to be | c | computed. | c | | c | 2) NCV = 20 sets the length of the Arnoldi | c | factorization. | c | | c | 3) This is a standard problem. | c | (indicated by bmat = 'I') | c | | c | 4) Ask for the NEV eigenvalues of | c | largest magnitude. | c | (indicated by which = 'LM') | c | See documentation in DNAUPD for the | c | other options SM, LR, SR, LI, SI. | c | | c | Note: NEV and NCV must satisfy the following | c | conditions: | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c | | c %-----------------------------------------------% c nev = 4 ncv = 20 bmat = 'I' which = 'LM' c if ( n .gt. maxn ) then print *, ' ERROR with _NSIMP: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NSIMP: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NSIMP: NCV is greater than MAXNCV ' go to 9000 end if c c %-----------------------------------------------------% c | | c | Specification of stopping rules and initial | c | conditions before calling DNAUPD | c | | c | TOL determines the stopping criterion. | c | | c | Expect | c | abs(lambdaC - lambdaT) < TOL*abs(lambdaC) | c | computed true | c | | c | If TOL .le. 0, then TOL <- macheps | c | (machine precision) is used. | c | | c | IDO is the REVERSE COMMUNICATION parameter | c | used to specify actions to be taken on return | c | from DNAUPD. (see usage below) | c | | c | It MUST initially be set to 0 before the first | c | call to DNAUPD. | c | | c | INFO on entry specifies starting vector information | c | and on return indicates error codes | c | | c | Initially, setting INFO=0 indicates that a | c | random starting vector is requested to | c | start the ARNOLDI iteration. Setting INFO to | c | a nonzero value on the initial call is used | c | if you want to specify your own starting | c | vector (This vector must be placed in RESID). | c | | c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. | c | | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | Specification of Algorithm Mode: | c | | c | This program uses the exact shift strategy | c | (indicated by setting IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of DNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | DNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode1 = 1 c iparam(1) = ishfts c iparam(3) = maxitr c iparam(7) = mode1 c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dnaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform matrix vector multiplication | c | y <--- Op*x | c | The user should supply his/her own | c | matrix vector multiplication routine here | c | that takes workd(ipntr(1)) as the input | c | vector, and return the matrix vector | c | product to workd(ipntr(2)). | c %-------------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 10 c endif c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ',info print *, ' Check the documentation of _naupd' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may be also computed now if | c | desired. (indicated by rvec = .true.) | c | | c | The routine DNEUPD now called to do this | c | post processing (Other modes may require | c | more complicated post processing than | c | mode1,) | c | | c %-------------------------------------------% c rvec = .true. c call dneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, ierr ) c c %------------------------------------------------% c | The real parts of the eigenvalues are returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part are returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first | c | NCONV (= IPARAM(5)) columns of the two | c | dimensional array V if requested. Otherwise, | c | an orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %------------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (IPARAM(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(nx, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex. | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(nx, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) call daxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) call av(nx, v(1,j+1), ax) call daxpy(n, -d(j,2), v(1,j), 1, ax, 1) call daxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real, Imag) and residual residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NSIMP ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dnsimp. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector subroutine c c The matrix used is the 2 dimensional convection-diffusion c operator discretized using central difference. c subroutine av (nx, v, w) integer nx, j, lo Double precision & v(nx*nx), w(nx*nx), one, h2 parameter (one = 1.0D+0) external daxpy, tv c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c derived from the standard central difference discretization c of the 2 dimensional convection-diffusion operator c (Laplacian u) + rho*(du/dx) on a unit square with zero boundary c condition. c c When rho*h/2 <= 1, the discrete convection-diffusion operator c has real eigenvalues. When rho*h/2 > 1, it has complex c eigenvalues. c c The subroutine TV is called to computed y<---T*x. c c h2 = one / dble((nx+1)*(nx+1)) c call tv(nx,v(1),w(1)) call daxpy(nx, -one/h2, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call daxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) call daxpy(nx, -one/h2, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call daxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) c return end c========================================================================= subroutine tv (nx, x, y) c integer nx, j Double precision & x(nx), y(nx), h, dd, dl, du, h2 c Double precision & one, rho parameter (one = 1.0D+0, rho = 1.0D+2) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal. c c When rho*h/2 <= 1, the discrete convection-diffusion operator c has real eigenvalues. When rho*h/2 > 1, it has complex c eigenvalues. c h = one / dble(nx+1) h2 = h*h dd = 4.0D+0 / h2 dl = -one/h2 - 5.0D-1*rho/h du = -one/h2 + 5.0D-1*rho/h c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/SIMPLE/dssimp.f0000644000175000017500000004732507172773736020406 0ustar andreasandreas program dssimp c c This example program is intended to illustrate the c simplest case of using ARPACK in considerable detail. c This code may be used to understand basic usage of ARPACK c and as a template for creating an interface to ARPACK. c c This code shows how to use ARPACK to find a few eigenvalues c (lambda) and corresponding eigenvectors (x) for the standard c eigenvalue problem: c c A*x = lambda*x c c where A is an n by n real symmetric matrix. c c The main points illustrated here are c c 1) How to declare sufficient memory to find NEV c eigenvalues of largest magnitude. Other options c are available. c c 2) Illustration of the reverse communication interface c needed to utilize the top level ARPACK routine DSAUPD c that computes the quantities needed to construct c the desired eigenvalues and eigenvectors(if requested). c c 3) How to extract the desired eigenvalues and eigenvectors c using the ARPACK routine DSEUPD. c c The only thing that must be supplied in order to use this c routine on your problem is to change the array dimensions c appropriately, to specify WHICH eigenvalues you want to compute c and to supply a matrix-vector product c c w <- Av c c in place of the call to AV( ) below. c c Once usage of this routine is understood, you may wish to explore c the other available options to improve convergence, to solve generalized c problems, etc. Look at the file ex-sym.doc in DOCUMENTS directory. c This codes implements c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is derived from the central difference discretization c of the 2-dimensional Laplacian on the unit square with c zero Dirichlet boundary condition. c ... OP = A and B = I. c ... Assume "call av (n,x,y)" computes y = A*x c ... Use mode 1 of DSAUPD. c c\BeginLib c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ssimp.F SID: 2.6 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c c %------------------------------------------------------% c | Storage Declarations: | c | | c | The maximum dimensions for all arrays are | c | set here to accommodate a problem size of | c | N .le. MAXN | c | | c | NEV is the number of eigenvalues requested. | c | See specifications for ARPACK usage below. | c | | c | NCV is the largest number of basis vectors that will | c | be used in the Implicitly Restarted Arnoldi | c | Process. Work per major iteration is | c | proportional to N*NCV*NCV. | c | | c | You must set: | c | | c | MAXN: Maximum dimension of the A allowed. | c | MAXNEV: Maximum NEV allowed. | c | MAXNCV: Maximum NCV allowed. | c %------------------------------------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, $ ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Double precision & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ax(maxn) logical select(maxncv) integer iparam(11), ipntr(11) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, & j, nx, ishfts, maxitr, mode1, nconv logical rvec Double precision & tol, sigma c c %------------% c | Parameters | c %------------% c Double precision & zero parameter (zero = 0.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dnrm2 external dnrm2, daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The following include statement and assignments | c | initiate trace output from the internal | c | actions of ARPACK. See debug.doc in the | c | DOCUMENTS directory for usage. Initially, the | c | most useful information will be a breakdown of | c | time spent in the various stages of computation | c | given by setting msaupd = 1. | c %-------------------------------------------------% c include 'debug.h' ndigit = -3 logfil = 6 msgets = 0 msaitr = 0 msapps = 0 msaupd = 1 msaup2 = 0 mseigt = 0 mseupd = 0 c c %-------------------------------------------------% c | The following sets dimensions for this problem. | c %-------------------------------------------------% c nx = 10 n = nx*nx c c %-----------------------------------------------% c | | c | Specifications for ARPACK usage are set | c | below: | c | | c | 1) NEV = 4 asks for 4 eigenvalues to be | c | computed. | c | | c | 2) NCV = 20 sets the length of the Arnoldi | c | factorization | c | | c | 3) This is a standard problem | c | (indicated by bmat = 'I') | c | | c | 4) Ask for the NEV eigenvalues of | c | largest magnitude | c | (indicated by which = 'LM') | c | See documentation in DSAUPD for the | c | other options SM, LA, SA, LI, SI. | c | | c | Note: NEV and NCV must satisfy the following | c | conditions: | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %-----------------------------------------------% c nev = 4 ncv = 20 bmat = 'I' which = 'LM' c if ( n .gt. maxn ) then print *, ' ERROR with _SSIMP: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SSIMP: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SSIMP: NCV is greater than MAXNCV ' go to 9000 end if c c %-----------------------------------------------------% c | | c | Specification of stopping rules and initial | c | conditions before calling DSAUPD | c | | c | TOL determines the stopping criterion. | c | | c | Expect | c | abs(lambdaC - lambdaT) < TOL*abs(lambdaC) | c | computed true | c | | c | If TOL .le. 0, then TOL <- macheps | c | (machine precision) is used. | c | | c | IDO is the REVERSE COMMUNICATION parameter | c | used to specify actions to be taken on return | c | from DSAUPD. (See usage below.) | c | | c | It MUST initially be set to 0 before the first | c | call to DSAUPD. | c | | c | INFO on entry specifies starting vector information | c | and on return indicates error codes | c | | c | Initially, setting INFO=0 indicates that a | c | random starting vector is requested to | c | start the ARNOLDI iteration. Setting INFO to | c | a nonzero value on the initial call is used | c | if you want to specify your own starting | c | vector (This vector must be placed in RESID.) | c | | c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. | c | | c %-----------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero info = 0 ido = 0 c c %---------------------------------------------------% c | Specification of Algorithm Mode: | c | | c | This program uses the exact shift strategy | c | (indicated by setting PARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of DSAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | DSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode1 = 1 c iparam(1) = ishfts c iparam(3) = maxitr c iparam(7) = mode1 c c %------------------------------------------------% c | M A I N L O O P (Reverse communication loop) | c %------------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dsaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %--------------------------------------% c | Perform matrix vector multiplication | c | y <--- OP*x | c | The user should supply his/her own | c | matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as | c | the input, and return the result to | c | workd(ipntr(2)). | c %--------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in DSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ', info print *, ' Check documentation in _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may be also computed now if | c | desired. (indicated by rvec = .true.) | c | | c | The routine DSEUPD now called to do this | c | post processing (Other modes may require | c | more complicated post processing than | c | mode1.) | c | | c %-------------------------------------------% c rvec = .true. c call dseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NCONV (=IPARAM(5)) columns of the | c | two dimensional array V if requested. | c | Otherwise, an orthogonal basis for the | c | invariant subspace corresponding to the | c | eigenvalues in D is returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(nx, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = dnrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SSIMP ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dssimp. | c %---------------------------% c 9000 continue c end c c ------------------------------------------------------------------ c matrix vector subroutine c c The matrix used is the 2 dimensional discrete Laplacian on unit c square with zero Dirichlet boundary condition. c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c The subroutine TV is called to computed y<---T*x. c subroutine av (nx, v, w) integer nx, j, lo, n2 Double precision & v(nx*nx), w(nx*nx), one, h2 parameter ( one = 1.0D+0 ) c call tv(nx,v(1),w(1)) call daxpy(nx, -one, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call daxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1) call daxpy(nx, -one, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call daxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1) c c Scale the vector w by (1/h^2), where h is the mesh size c n2 = nx*nx h2 = one / dble((nx+1)*(nx+1)) call dscal(n2, one/h2, w, 1) return end c c------------------------------------------------------------------- subroutine tv (nx, x, y) c integer nx, j Double precision & x(nx), y(nx), dd, dl, du c Double precision & one, four parameter (one = 1.0D+0, four = 4.0D+0) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal. c c dd = four dl = -one du = -one c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/SIMPLE/snsimp.f0000644000175000017500000005351607172773453020413 0ustar andreasandreas program snsimp c c c This example program is intended to illustrate the c simplest case of using ARPACK in considerable detail. c This code may be used to understand basic usage of ARPACK c and as a template for creating an interface to ARPACK. c c This code shows how to use ARPACK to find a few eigenvalues c (lambda) and corresponding eigenvectors (x) for the standard c eigenvalue problem: c c A*x = lambda*x c c where A is a n by n real nonsymmetric matrix. c c The main points illustrated here are c c 1) How to declare sufficient memory to find NEV c eigenvalues of largest magnitude. Other options c are available. c c 2) Illustration of the reverse communication interface c needed to utilize the top level ARPACK routine SNAUPD c that computes the quantities needed to construct c the desired eigenvalues and eigenvectors(if requested). c c 3) How to extract the desired eigenvalues and eigenvectors c using the ARPACK routine SNEUPD. c c The only thing that must be supplied in order to use this c routine on your problem is to change the array dimensions c appropriately, to specify WHICH eigenvalues you want to compute c and to supply a matrix-vector product c c w <- Av c c in place of the call to AV( ) below. c c Once usage of this routine is understood, you may wish to explore c the other available options to improve convergence, to solve generalized c problems, etc. Look at the file ex-nonsym.doc in DOCUMENTS directory. c This codes implements c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is obtained from the standard central difference c discretization of the convection-diffusion operator c (Laplacian u) + rho*(du / dx) c on the unit square, with zero Dirichlet boundary condition. c c ... OP = A and B = I. c ... Assume "call av (nx,x,y)" computes y = A*x c ... Use mode 1 of SNAUPD. c c\BeginLib c c\Routines called: c snaupd ARPACK reverse communication interface routine. c sneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nsimp.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c--------------------------------------------------------------------------- c c %------------------------------------------------------% c | Storage Declarations: | c | | c | The maximum dimensions for all arrays are | c | set here to accommodate a problem size of | c | N .le. MAXN | c | | c | NEV is the number of eigenvalues requested. | c | See specifications for ARPACK usage below. | c | | c | NCV is the largest number of basis vectors that will | c | be used in the Implicitly Restarted Arnoldi | c | Process. Work per major iteration is | c | proportional to N*NCV*NCV. | c | | c | You must set: | c | | c | MAXN: Maximum dimension of the A allowed. | c | MAXNEV: Maximum NEV allowed. | c | MAXNCV: Maximum NCV allowed. | c %------------------------------------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=12, maxncv=30, ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Real & ax(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nx, nev, ncv, lworkl, info, ierr, & j, ishfts, maxitr, mode1, nconv Real & tol, sigmar, sigmai logical first, rvec c c %------------% c | Parameters | c %------------% c Real & zero parameter (zero = 0.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The following include statement and assignments | c | initiate trace output from the internal | c | actions of ARPACK. See debug.doc in the | c | DOCUMENTS directory for usage. Initially, the | c | most useful information will be a breakdown of | c | time spent in the various stages of computation | c | given by setting mnaupd = 1. | c %-------------------------------------------------% c include 'debug.h' ndigit = -3 logfil = 6 mnaitr = 0 mnapps = 0 mnaupd = 1 mnaup2 = 0 mneigh = 0 mneupd = 0 c c %-------------------------------------------------% c | The following sets dimensions for this problem. | c %-------------------------------------------------% c nx = 10 n = nx*nx c c %-----------------------------------------------% c | | c | Specifications for ARPACK usage are set | c | below: | c | | c | 1) NEV = 4 asks for 4 eigenvalues to be | c | computed. | c | | c | 2) NCV = 20 sets the length of the Arnoldi | c | factorization. | c | | c | 3) This is a standard problem. | c | (indicated by bmat = 'I') | c | | c | 4) Ask for the NEV eigenvalues of | c | largest magnitude. | c | (indicated by which = 'LM') | c | See documentation in SNAUPD for the | c | other options SM, LR, SR, LI, SI. | c | | c | Note: NEV and NCV must satisfy the following | c | conditions: | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c | | c %-----------------------------------------------% c nev = 4 ncv = 20 bmat = 'I' which = 'LM' c if ( n .gt. maxn ) then print *, ' ERROR with _NSIMP: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NSIMP: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NSIMP: NCV is greater than MAXNCV ' go to 9000 end if c c %-----------------------------------------------------% c | | c | Specification of stopping rules and initial | c | conditions before calling SNAUPD | c | | c | TOL determines the stopping criterion. | c | | c | Expect | c | abs(lambdaC - lambdaT) < TOL*abs(lambdaC) | c | computed true | c | | c | If TOL .le. 0, then TOL <- macheps | c | (machine precision) is used. | c | | c | IDO is the REVERSE COMMUNICATION parameter | c | used to specify actions to be taken on return | c | from SNAUPD. (see usage below) | c | | c | It MUST initially be set to 0 before the first | c | call to SNAUPD. | c | | c | INFO on entry specifies starting vector information | c | and on return indicates error codes | c | | c | Initially, setting INFO=0 indicates that a | c | random starting vector is requested to | c | start the ARNOLDI iteration. Setting INFO to | c | a nonzero value on the initial call is used | c | if you want to specify your own starting | c | vector (This vector must be placed in RESID). | c | | c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. | c | | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | Specification of Algorithm Mode: | c | | c | This program uses the exact shift strategy | c | (indicated by setting IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of SNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | SNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode1 = 1 c iparam(1) = ishfts c iparam(3) = maxitr c iparam(7) = mode1 c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call snaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform matrix vector multiplication | c | y <--- Op*x | c | The user should supply his/her own | c | matrix vector multiplication routine here | c | that takes workd(ipntr(1)) as the input | c | vector, and return the matrix vector | c | product to workd(ipntr(2)). | c %-------------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 10 c endif c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ',info print *, ' Check the documentation of _naupd' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may be also computed now if | c | desired. (indicated by rvec = .true.) | c | | c | The routine SNEUPD now called to do this | c | post processing (Other modes may require | c | more complicated post processing than | c | mode1,) | c | | c %-------------------------------------------% c rvec = .true. c call sneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, ierr ) c c %------------------------------------------------% c | The real parts of the eigenvalues are returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part are returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first | c | NCONV (= IPARAM(5)) columns of the two | c | dimensional array V if requested. Otherwise, | c | an orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %------------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (IPARAM(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(nx, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex. | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(nx, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) call saxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call av(nx, v(1,j+1), ax) call saxpy(n, -d(j,2), v(1,j), 1, ax, 1) call saxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real, Imag) and residual residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NSIMP ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program snsimp. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector subroutine c c The matrix used is the 2 dimensional convection-diffusion c operator discretized using central difference. c subroutine av (nx, v, w) integer nx, j, lo Real & v(nx*nx), w(nx*nx), one, h2 parameter (one = 1.0E+0) external saxpy, tv c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c derived from the standard central difference discretization c of the 2 dimensional convection-diffusion operator c (Laplacian u) + rho*(du/dx) on a unit square with zero boundary c condition. c c When rho*h/2 <= 1, the discrete convection-diffusion operator c has real eigenvalues. When rho*h/2 > 1, it has complex c eigenvalues. c c The subroutine TV is called to computed y<---T*x. c c h2 = one / real((nx+1)*(nx+1)) c call tv(nx,v(1),w(1)) call saxpy(nx, -one/h2, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call saxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) call saxpy(nx, -one/h2, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call saxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) c return end c========================================================================= subroutine tv (nx, x, y) c integer nx, j Real & x(nx), y(nx), h, dd, dl, du, h2 c Real & one, rho parameter (one = 1.0E+0, rho = 1.0E+2) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal. c c When rho*h/2 <= 1, the discrete convection-diffusion operator c has real eigenvalues. When rho*h/2 > 1, it has complex c eigenvalues. c h = one / real(nx+1) h2 = h*h dd = 4.0E+0 / h2 dl = -one/h2 - 5.0E-1*rho/h du = -one/h2 + 5.0E-1*rho/h c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/SIMPLE/sssimp.f0000644000175000017500000004720107172773736020416 0ustar andreasandreas program sssimp c c This example program is intended to illustrate the c simplest case of using ARPACK in considerable detail. c This code may be used to understand basic usage of ARPACK c and as a template for creating an interface to ARPACK. c c This code shows how to use ARPACK to find a few eigenvalues c (lambda) and corresponding eigenvectors (x) for the standard c eigenvalue problem: c c A*x = lambda*x c c where A is an n by n real symmetric matrix. c c The main points illustrated here are c c 1) How to declare sufficient memory to find NEV c eigenvalues of largest magnitude. Other options c are available. c c 2) Illustration of the reverse communication interface c needed to utilize the top level ARPACK routine SSAUPD c that computes the quantities needed to construct c the desired eigenvalues and eigenvectors(if requested). c c 3) How to extract the desired eigenvalues and eigenvectors c using the ARPACK routine SSEUPD. c c The only thing that must be supplied in order to use this c routine on your problem is to change the array dimensions c appropriately, to specify WHICH eigenvalues you want to compute c and to supply a matrix-vector product c c w <- Av c c in place of the call to AV( ) below. c c Once usage of this routine is understood, you may wish to explore c the other available options to improve convergence, to solve generalized c problems, etc. Look at the file ex-sym.doc in DOCUMENTS directory. c This codes implements c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is derived from the central difference discretization c of the 2-dimensional Laplacian on the unit square with c zero Dirichlet boundary condition. c ... OP = A and B = I. c ... Assume "call av (n,x,y)" computes y = A*x c ... Use mode 1 of SSAUPD. c c\BeginLib c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ssimp.F SID: 2.6 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c c %------------------------------------------------------% c | Storage Declarations: | c | | c | The maximum dimensions for all arrays are | c | set here to accommodate a problem size of | c | N .le. MAXN | c | | c | NEV is the number of eigenvalues requested. | c | See specifications for ARPACK usage below. | c | | c | NCV is the largest number of basis vectors that will | c | be used in the Implicitly Restarted Arnoldi | c | Process. Work per major iteration is | c | proportional to N*NCV*NCV. | c | | c | You must set: | c | | c | MAXN: Maximum dimension of the A allowed. | c | MAXNEV: Maximum NEV allowed. | c | MAXNCV: Maximum NCV allowed. | c %------------------------------------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, $ ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Real & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ax(maxn) logical select(maxncv) integer iparam(11), ipntr(11) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, & j, nx, ishfts, maxitr, mode1, nconv logical rvec Real & tol, sigma c c %------------% c | Parameters | c %------------% c Real & zero parameter (zero = 0.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & snrm2 external snrm2, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The following include statement and assignments | c | initiate trace output from the internal | c | actions of ARPACK. See debug.doc in the | c | DOCUMENTS directory for usage. Initially, the | c | most useful information will be a breakdown of | c | time spent in the various stages of computation | c | given by setting msaupd = 1. | c %-------------------------------------------------% c include 'debug.h' ndigit = -3 logfil = 6 msgets = 0 msaitr = 0 msapps = 0 msaupd = 1 msaup2 = 0 mseigt = 0 mseupd = 0 c c %-------------------------------------------------% c | The following sets dimensions for this problem. | c %-------------------------------------------------% c nx = 10 n = nx*nx c c %-----------------------------------------------% c | | c | Specifications for ARPACK usage are set | c | below: | c | | c | 1) NEV = 4 asks for 4 eigenvalues to be | c | computed. | c | | c | 2) NCV = 20 sets the length of the Arnoldi | c | factorization | c | | c | 3) This is a standard problem | c | (indicated by bmat = 'I') | c | | c | 4) Ask for the NEV eigenvalues of | c | largest magnitude | c | (indicated by which = 'LM') | c | See documentation in SSAUPD for the | c | other options SM, LA, SA, LI, SI. | c | | c | Note: NEV and NCV must satisfy the following | c | conditions: | c | NEV <= MAXNEV | c | NEV + 1 <= NCV <= MAXNCV | c %-----------------------------------------------% c nev = 4 ncv = 20 bmat = 'I' which = 'LM' c if ( n .gt. maxn ) then print *, ' ERROR with _SSIMP: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SSIMP: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SSIMP: NCV is greater than MAXNCV ' go to 9000 end if c c %-----------------------------------------------------% c | | c | Specification of stopping rules and initial | c | conditions before calling SSAUPD | c | | c | TOL determines the stopping criterion. | c | | c | Expect | c | abs(lambdaC - lambdaT) < TOL*abs(lambdaC) | c | computed true | c | | c | If TOL .le. 0, then TOL <- macheps | c | (machine precision) is used. | c | | c | IDO is the REVERSE COMMUNICATION parameter | c | used to specify actions to be taken on return | c | from SSAUPD. (See usage below.) | c | | c | It MUST initially be set to 0 before the first | c | call to SSAUPD. | c | | c | INFO on entry specifies starting vector information | c | and on return indicates error codes | c | | c | Initially, setting INFO=0 indicates that a | c | random starting vector is requested to | c | start the ARNOLDI iteration. Setting INFO to | c | a nonzero value on the initial call is used | c | if you want to specify your own starting | c | vector (This vector must be placed in RESID.) | c | | c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. | c | | c %-----------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero info = 0 ido = 0 c c %---------------------------------------------------% c | Specification of Algorithm Mode: | c | | c | This program uses the exact shift strategy | c | (indicated by setting PARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of SSAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | SSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode1 = 1 c iparam(1) = ishfts c iparam(3) = maxitr c iparam(7) = mode1 c c %------------------------------------------------% c | M A I N L O O P (Reverse communication loop) | c %------------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call ssaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %--------------------------------------% c | Perform matrix vector multiplication | c | y <--- OP*x | c | The user should supply his/her own | c | matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as | c | the input, and return the result to | c | workd(ipntr(2)). | c %--------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in SSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ', info print *, ' Check documentation in _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may be also computed now if | c | desired. (indicated by rvec = .true.) | c | | c | The routine SSEUPD now called to do this | c | post processing (Other modes may require | c | more complicated post processing than | c | mode1.) | c | | c %-------------------------------------------% c rvec = .true. c call sseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NCONV (=IPARAM(5)) columns of the | c | two dimensional array V if requested. | c | Otherwise, an orthogonal basis for the | c | invariant subspace corresponding to the | c | eigenvalues in D is returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(nx, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SSIMP ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program sssimp. | c %---------------------------% c 9000 continue c end c c ------------------------------------------------------------------ c matrix vector subroutine c c The matrix used is the 2 dimensional discrete Laplacian on unit c square with zero Dirichlet boundary condition. c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c The subroutine TV is called to computed y<---T*x. c subroutine av (nx, v, w) integer nx, j, lo, n2 Real & v(nx*nx), w(nx*nx), one, h2 parameter ( one = 1.0E+0 ) c call tv(nx,v(1),w(1)) call saxpy(nx, -one, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call saxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1) call saxpy(nx, -one, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call saxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1) c c Scale the vector w by (1/h^2), where h is the mesh size c n2 = nx*nx h2 = one / real((nx+1)*(nx+1)) call sscal(n2, one/h2, w, 1) return end c c------------------------------------------------------------------- subroutine tv (nx, x, y) c integer nx, j Real & x(nx), y(nx), dd, dl, du c Real & one, four parameter (one = 1.0E+0, four = 4.0E+0) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal. c c dd = four dl = -one du = -one c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/SIMPLE/znsimp.f0000644000175000017500000005074107174076744020420 0ustar andreasandreas program znsimp c c This example program is intended to illustrate the c simplest case of using ARPACK in considerable detail. c This code may be used to understand basic usage of ARPACK c and as a template for creating an interface to ARPACK. c c This code shows how to use ARPACK to find a few eigenvalues c (lambda) and corresponding eigenvectors (x) for the standard c eigenvalue problem: c c A*x = lambda*x c c where A is a general n by n complex matrix. c c The main points illustrated here are c c 1) How to declare sufficient memory to find NEV c eigenvalues of largest magnitude. Other options c are available. c c 2) Illustration of the reverse communication interface c needed to utilize the top level ARPACK routine ZNAUPD c that computes the quantities needed to construct c the desired eigenvalues and eigenvectors(if requested). c c 3) How to extract the desired eigenvalues and eigenvectors c using the ARPACK routine ZNEUPD . c c The only thing that must be supplied in order to use this c routine on your problem is to change the array dimensions c appropriately, to specify WHICH eigenvalues you want to compute c and to supply a matrix-vector product c c w <- Av c c in place of the call to AV( ) below. c c c Once usage of this routine is understood, you may wish to explore c the other available options to improve convergence, to solve generalized c problems, etc. Look at the file ex-complex.doc in DOCUMENTS directory. c This codes implements c c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c ... OP = A and B = I. c ... Assume "call av (nx,x,y)" computes y = A*x c ... Use mode 1 of ZNAUPD . c c\BeginLib c c\Routines called c znaupd ARPACK reverse communication interface routine. c zneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c dznrm2 Level 1 BLAS that computes the norm of a complex vector. c zaxpy Level 1 BLAS that computes y <- alpha*x+y. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: nsimp.F SID: 2.4 DATE OF SID: 10/20/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c--------------------------------------------------------------------------- c c %------------------------------------------------------% c | Storage Declarations: | c | | c | The maximum dimensions for all arrays are | c | set here to accommodate a problem size of | c | N .le. MAXN | c | | c | NEV is the number of eigenvalues requested. | c | See specifications for ARPACK usage below. | c | | c | NCV is the largest number of basis vectors that will | c | be used in the Implicitly Restarted Arnoldi | c | Process. Work per major iteration is | c | proportional to N*NCV*NCV. | c | | c | You must set: | c | | c | MAXN: Maximum dimension of the A allowed. | c | MAXNEV: Maximum NEV allowed. | c | MAXNCV: Maximum NCV allowed. | c %------------------------------------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=12, maxncv=30, ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Complex*16 & ax(maxn), d(maxncv), & v(ldv,maxncv), workd(3*maxn), & workev(2*maxncv), resid(maxn), & workl(3*maxncv*maxncv+5*maxncv) Double precision & rwork(maxncv), rd(maxncv,3) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nx, nev, ncv, lworkl, info, ierr, & j, ishfts, maxitr, mode1, nconv Complex*16 & sigma Double precision & tol logical rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dznrm2 , dlapy2 external dznrm2 , zaxpy , dlapy2 c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The following include statement and assignments | c | initiate trace output from the internal | c | actions of ARPACK. See debug.doc in the | c | DOCUMENTS directory for usage. Initially, the | c | most useful information will be a breakdown of | c | time spent in the various stages of computation | c | given by setting mcaupd = 1 | c %-------------------------------------------------% c include 'debug.h' ndigit = -3 logfil = 6 mcaitr = 0 mcapps = 0 mcaupd = 1 mcaup2 = 0 mceigh = 0 mceupd = 0 c c %-------------------------------------------------% c | The following sets dimensions for this problem. | c %-------------------------------------------------% c nx = 10 n = nx*nx c c %-----------------------------------------------% c | | c | Specifications for ARPACK usage are set | c | below: | c | | c | 1) NEV = 4 asks for 4 eigenvalues to be | c | computed. | c | | c | 2) NCV = 20 sets the length of the Arnoldi | c | factorization | c | | c | 3) This is a standard problem | c | (indicated by bmat = 'I') | c | | c | 4) Ask for the NEV eigenvalues of | c | largest magnitude | c | (indicated by which = 'LM') | c | See documentation in ZNAUPD for the | c | other options SM, LR, SR, LI, SI. | c | | c | Note: NEV and NCV must satisfy the following | c | conditions: | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c | | c %-----------------------------------------------% c nev = 4 ncv = 20 bmat = 'I' which = 'LM' c if ( n .gt. maxn ) then print *, ' ERROR with _NSIMP: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NSIMP: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NSIMP: NCV is greater than MAXNCV ' go to 9000 end if c c %-----------------------------------------------------% c | | c | Specification of stopping rules and initial | c | conditions before calling ZNAUPD | c | | c | TOL determines the stopping criterion. | c | | c | Expect | c | abs(lambdaC - lambdaT) < TOL*abs(lambdaC) | c | computed true | c | | c | If TOL .le. 0, then TOL <- macheps | c | (machine precision) is used. | c | | c | IDO is the REVERSE COMMUNICATION parameter | c | used to specify actions to be taken on return | c | from ZNAUPD . (see usage below) | c | | c | It MUST initially be set to 0 before the first | c | call to ZNAUPD . | c | | c | INFO on entry specifies starting vector information | c | and on return indicates error codes | c | | c | Initially, setting INFO=0 indicates that a | c | random starting vector is requested to | c | start the ARNOLDI iteration. Setting INFO to | c | a nonzero value on the initial call is used | c | if you want to specify your own starting | c | vector (This vector must be placed in RESID). | c | | c | The work array WORKL is used in ZNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. | c | | c %-----------------------------------------------------% c lworkl = 3*ncv**2+5*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | Specification of Algorithm Mode: | c | | c | This program uses the exact shift strategy | c | (indicated by setting IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of ZNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | ZNAUPD . | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode1 = 1 c iparam(1) = ishfts c iparam(3) = maxitr c iparam(7) = mode1 c c %------------------------------------------------% c | M A I N L O O P (Reverse Communication Loop) | c %------------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine ZNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% call znaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork,info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform matrix vector multiplication | c | | c | y <--- A*x | c | | c | The user should supply his/her own | c | matrix vector multiplication routine here | c | that takes workd(ipntr(1)) as the input | c | vector x , and returns the resulting | c | matrix-vector product y = A*x in the | c | array workd(ipntr(2)). | c %-------------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call ZNAUPD again. | c %-----------------------------------------% c go to 10 c endif c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in ZNAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using ZNEUPD . | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may be also computed now if | c | desired. (indicated by rvec = .true.) | c | | c | The routine ZNEUPD now called to do this | c | post processing (Other modes may require | c | more complicated post processing than | c | mode1.) | c | | c %-------------------------------------------% c rvec = .true. c call zneupd (rvec, 'A', select, D, V, ldv, sigma, & workev, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & rwork, ierr) c c %-----------------------------------------------% c | Eigenvalues are returned in the one | c | dimensional array D and the corresponding | c | eigenvectors are returned in the first | c | NCONV (=IPARAM(5)) columns of the two | c | dimensional array V if requested. Otherwise, | c | an orthogonal basis for the invariant | c | subspace corresponding to the eigenvalues in | c | D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of ZNEUPD . | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(nx, v(1,j), ax) call zaxpy (n, -d(j), v(1,j), 1, ax, 1) rd(j,1) = dble (d(j)) rd(j,2) = dimag (d(j)) rd(j,3) = dznrm2 (n, ax, 1) rd(j,3) = rd(j,3) / dlapy2 (rd(j,1),rd(j,2)) 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout (6, nconv, 3, rd, maxncv, -6, & 'Ritz values (Real, Imag) and relative residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, '_NSIMP ' print *, '====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program znsimp . | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector subroutine c c The matrix used is the convection-diffusion operator c discretized using centered difference. c subroutine av (nx, v, w) integer nx, j, lo Complex*16 & v(nx*nx), w(nx*nx), one, h2 parameter (one = (1.0D+0, 0.0D+0) ) external zaxpy c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c derived from the standard central difference discretization c of the 2-dimensional convection-diffusion operator c (Laplacian u) + rho*(du/dx) c on the unit squqre with zero boundary condition. c c The subroutine TV is called to computed y<---T*x. c c h2 = one / dcmplx ((nx+1)*(nx+1)) c call tv(nx,v(1),w(1)) call zaxpy (nx, -one/h2, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call zaxpy (nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) call zaxpy (nx, -one/h2, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call zaxpy (nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) c return end c========================================================================= subroutine tv (nx, x, y) c integer nx, j Complex*16 & x(nx), y(nx), h, h2, dd, dl, du c Complex*16 & one, rho parameter (one = (1.0D+0, 0.0D+0) , & rho = (1.0D+2, 0.0D+0) ) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal c h = one / dcmplx (nx+1) h2 = h*h dd = (4.0D+0, 0.0D+0) / h2 dl = -one/h2 - (5.0D-1, 0.0D+0) *rho/h du = -one/h2 + (5.0D-1, 0.0D+0) *rho/h c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/SIMPLE/makefile0000644000175000017500000000127306221772144020412 0ustar andreasandreas# # makefile to run simple examples of the reverse communication # protocol. # # Modify if ARPACK library was built somewhere else. # #\SCCS Information: @(#) # FILE: makefile SID: 2.2 DATE OF SID: 9/24/96 RELEASE: 2 # include ../../ARmake.inc # # simple drivers # simple: sssimp dssimp snsimp dnsimp cnsimp znsimp # sssimp: sssimp.o $(FC) $(FFLAGS) sssimp.o $(ALIBS) -o sssimp dssimp: dssimp.o $(FC) $(FFLAGS) dssimp.o $(ALIBS) -o dssimp snsimp: snsimp.o $(FC) $(FFLAGS) snsimp.o $(ALIBS) -o snsimp dnsimp: dnsimp.o $(FC) $(FFLAGS) dnsimp.o $(ALIBS) -o dnsimp cnsimp: cnsimp.o $(FC) $(FFLAGS) cnsimp.o $(ALIBS) -o cnsimp znsimp: znsimp.o $(FC) $(FFLAGS) znsimp.o $(ALIBS) -o znsimp arpack-akloeckner-07/EXAMPLES/SIMPLE/README0000644000175000017500000000151706053172413017567 0ustar andreasandreas1. Purpose ------- This directory contains simple example drivers that call ARPACK subroutine __aupd.f and __eupd.f to solve various eigenvalue problems using regular mode. These drivers illustrate how to use ARPACK in considerable detail. If you have never used ARPACK before, this is the place to start. 2. Naming Convention ----------------- The name for each driver has the form 'XYsimp.f', where X - is 's' (single precision) or 'd' (double precision) or 'c' (single complex) or 'z' (double complex) Y - is 's' (symmetric) or 'n' (nonsymmetric) Note: there is no simple driver specifically for hermitian complex. 3. Usage ----- To run these drivers, you may use the makefile in this directory and issue, for example, "make sssimp". Then execute using "sssimp". arpack-akloeckner-07/EXAMPLES/SIMPLE/debug.h0000644000175000017500000000135106053174545020152 0ustar andreasandreasc c\SCCS Information: @(#) c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 c c %---------------------------------% c | See debug.doc for documentation | c %---------------------------------% integer logfil, ndigit, mgetv0, & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd common /debug/ & logfil, ndigit, mgetv0, & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd arpack-akloeckner-07/EXAMPLES/SVD/0000755000175000017500000000000007172772703016361 5ustar andreasandreasarpack-akloeckner-07/EXAMPLES/SVD/dsvd.f0000644000175000017500000005260407172772613017477 0ustar andreasandreas program dsvd c c This example program is intended to illustrate the c the use of ARPACK to compute the Singular Value Decomposition. c c This code shows how to use ARPACK to find a few of the c largest singular values(sigma) and corresponding right singular c vectors (v) for the the matrix A by solving the symmetric problem: c c (A'*A)*v = sigma*v c c where A is an m by n real matrix. c c This code may be easily modified to estimate the 2-norm c condition number largest(sigma)/smallest(sigma) by setting c which = 'BE' below. This will ask for a few of the smallest c and a few of the largest singular values simultaneously. c The condition number could then be estimated by taking c the ratio of the largest and smallest singular values. c c This formulation is appropriate when m .ge. n. c Reverse the roles of A and A' in the case that m .le. n. c c The main points illustrated here are c c 1) How to declare sufficient memory to find NEV c largest singular values of A . c c 2) Illustration of the reverse communication interface c needed to utilize the top level ARPACK routine DSAUPD c that computes the quantities needed to construct c the desired singular values and vectors(if requested). c c 3) How to extract the desired singular values and vectors c using the ARPACK routine DSEUPD. c c 4) How to construct the left singular vectors U from the c right singular vectors V to obtain the decomposition c c A*V = U*S c c where S = diag(sigma_1, sigma_2, ..., sigma_k). c c The only thing that must be supplied in order to use this c routine on your problem is to change the array dimensions c appropriately, to specify WHICH singular values you want to c compute and to supply a the matrix-vector products c c w <- Ax c y <- A'w c c in place of the calls to AV( ) and ATV( ) respectively below. c c Further documentation is available in the header of DSAUPD c which may be found in the SRC directory. c c This codes implements c c\Example-1 c ... Suppose we want to solve A'A*v = sigma*v in regular mode, c where A is derived from the simplest finite difference c discretization of the 2-dimensional kernel K(s,t)dt where c c K(s,t) = s(t-1) if 0 .le. s .le. t .le. 1, c t(s-1) if 0 .le. t .lt. s .le. 1. c c See subroutines AV and ATV for details. c ... OP = A'*A and B = I. c ... Assume "call av (n,x,y)" computes y = A*x c ... Assume "call atv (n,y,w)" computes w = A'*y c ... Assume exact shifts are used c ... c c\BeginLib c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dscal Level 1 BLAS thst computes x <- x*alpha. c dcopy Level 1 BLAS thst computes y <- x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: svd.F SID: 2.4 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c c %------------------------------------------------------% c | Storage Declarations: | c | | c | It is assumed that A is M by N with M .ge. N. | c | | c | The maximum dimensions for all arrays are | c | set here to accommodate a problem size of | c | M .le. MAXM and N .le. MAXN | c | | c | The NEV right singular vectors will be computed in | c | the N by NCV array V. | c | | c | The NEV left singular vectors will be computed in | c | the M by NEV array U. | c | | c | NEV is the number of singular values requested. | c | See specifications for ARPACK usage below. | c | | c | NCV is the largest number of basis vectors that will | c | be used in the Implicitly Restarted Arnoldi | c | Process. Work per major iteration is | c | proportional to N*NCV*NCV. | c | | c | You must set: | c | | c | MAXM: Maximum number of rows of the A allowed. | c | MAXN: Maximum number of columns of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %------------------------------------------------------% c integer maxm, maxn, maxnev, maxncv, ldv, ldu parameter (maxm = 500, maxn=250, maxnev=10, maxncv=25, & ldu = maxm, ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Double precision & v(ldv,maxncv), u(ldu, maxnev), & workl(maxncv*(maxncv+8)), workd(3*maxn), & s(maxncv,2), resid(maxn), ax(maxm) logical select(maxncv) integer iparam(11), ipntr(11) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, m, n, nev, ncv, lworkl, info, ierr, & j, ishfts, maxitr, mode1, nconv logical rvec Double precision & tol, sigma, temp c c %------------% c | Parameters | c %------------% c Double precision & one, zero parameter (one = 1.0D+0, zero = 0.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dnrm2 external dnrm2, daxpy, dcopy, dscal c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The following include statement and assignments | c | initiate trace output from the internal | c | actions of ARPACK. See debug.doc in the | c | DOCUMENTS directory for usage. Initially, the | c | most useful information will be a breakdown of | c | time spent in the various stages of computation | c | given by setting msaupd = 1. | c %-------------------------------------------------% c include 'debug.h' ndigit = -3 logfil = 6 msgets = 0 msaitr = 0 msapps = 0 msaupd = 1 msaup2 = 0 mseigt = 0 mseupd = 0 c c %-------------------------------------------------% c | The following sets dimensions for this problem. | c %-------------------------------------------------% c m = 500 n = 100 c c %------------------------------------------------% c | Specifications for ARPACK usage are set | c | below: | c | | c | 1) NEV = 4 asks for 4 singular values to be | c | computed. | c | | c | 2) NCV = 20 sets the length of the Arnoldi | c | factorization | c | | c | 3) This is a standard problem | c | (indicated by bmat = 'I') | c | | c | 4) Ask for the NEV singular values of | c | largest magnitude | c | (indicated by which = 'LM') | c | See documentation in DSAUPD for the | c | other options SM, BE. | c | | c | Note: NEV and NCV must satisfy the following | c | conditions: | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %------------------------------------------------% c nev = 4 ncv = 10 bmat = 'I' which = 'LM' c if ( n .gt. maxn ) then print *, ' ERROR with _SVD: N is greater than MAXN ' go to 9000 else if ( m .gt. maxm ) then print *, ' ERROR with _SVD: M is greater than MAXM ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SVD: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SVD: NCV is greater than MAXNCV ' go to 9000 end if c c %-----------------------------------------------------% c | Specification of stopping rules and initial | c | conditions before calling DSAUPD | c | | c | abs(sigmaC - sigmaT) < TOL*abs(sigmaC) | c | computed true | c | | c | If TOL .le. 0, then TOL <- macheps | c | (machine precision) is used. | c | | c | IDO is the REVERSE COMMUNICATION parameter | c | used to specify actions to be taken on return | c | from DSAUPD. (See usage below.) | c | | c | It MUST initially be set to 0 before the first | c | call to DSAUPD. | c | | c | INFO on entry specifies starting vector information | c | and on return indicates error codes | c | | c | Initially, setting INFO=0 indicates that a | c | random starting vector is requested to | c | start the ARNOLDI iteration. Setting INFO to | c | a nonzero value on the initial call is used | c | if you want to specify your own starting | c | vector (This vector must be placed in RESID.) | c | | c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. | c %-----------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero info = 0 ido = 0 c c %---------------------------------------------------% c | Specification of Algorithm Mode: | c | | c | This program uses the exact shift strategy | c | (indicated by setting IPARAM(1) = 1.) | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of DSAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | DSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = n mode1 = 1 c iparam(1) = ishfts c iparam(3) = maxitr c iparam(7) = mode1 c c %------------------------------------------------% c | M A I N L O O P (Reverse communication loop) | c %------------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dsaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %---------------------------------------% c | Perform matrix vector multiplications | c | w <--- A*x (av()) | c | y <--- A'*w (atv()) | c | The user should supply his/her own | c | matrix vector multiplication routines | c | here that takes workd(ipntr(1)) as | c | the input, and returns the result in | c | workd(ipntr(2)). | c %---------------------------------------% c call av (m, n, workd(ipntr(1)), ax) call atv (m, n, ax, workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in DSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ', info print *, ' Check documentation in _saupd ' print *, ' ' c else c c %--------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DSEUPD. | c | | c | Computed singular values may be extracted. | c | | c | Singular vectors may also be computed now | c | if desired. (indicated by rvec = .true.) | c | | c | The routine DSEUPD now called to do this | c | post processing | c %--------------------------------------------% c rvec = .true. c call dseupd ( rvec, 'All', select, s, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %-----------------------------------------------% c | Singular values are returned in the first | c | column of the two dimensional array S | c | and the corresponding right singular vectors | c | are returned in the first NEV columns of the | c | two dimensional array V as requested here. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c s(j,1) = sqrt(s(j,1)) c c %-----------------------------% c | Compute the left singular | c | vectors from the formula | c | | c | u = Av/sigma | c | | c | u should have norm 1 so | c | divide by norm(Av) instead. | c %-----------------------------% c call av(m, n, v(1,j), ax) call dcopy(m, ax, 1, u(1,j), 1) temp = one/dnrm2(m, u(1,j), 1) call dscal(m, temp, u(1,j), 1) c c %---------------------------% c | | c | Compute the residual norm | c | | c | || A*v - sigma*u || | c | | c | for the NCONV accurately | c | computed singular values | c | and vectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance). | c | Store the result in 2nd | c | column of array S. | c %---------------------------% c call daxpy(m, -s(j,1), u(1,j), 1, ax, 1) s(j,2) = dnrm2(m, ax, 1) c 20 continue c c %-------------------------------% c | Display computed residuals | c %-------------------------------% c call dmout(6, nconv, 2, s, maxncv, -6, & 'Singular values and direct residuals') end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SVD ' print *, ' ==== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %-------------------------% c | Done with program dsvd. | c %-------------------------% c 9000 continue c end c c ------------------------------------------------------------------ c matrix vector subroutines c c The matrix A is derived from the simplest finite difference c discretization of the integral operator c c f(s) = integral(K(s,t)x(t)dt). c c Thus, the matrix A is a discretization of the 2-dimensional kernel c K(s,t)dt, where c c K(s,t) = s(t-1) if 0 .le. s .le. t .le. 1, c t(s-1) if 0 .le. t .lt. s .le. 1. c c Thus A is an m by n matrix with entries c c A(i,j) = k*(si)*(tj - 1) if i .le. j, c k*(tj)*(si - 1) if i .gt. j c c where si = i/(m+1) and tj = j/(n+1) and k = 1/(n+1). c c------------------------------------------------------------------- c subroutine av (m, n, x, w) c c computes w <- A*x c integer m, n, i, j Double precision & x(n), w(m), one, zero, h, k, s, t parameter ( one = 1.0D+0, zero = 0.0D+0 ) c h = one / dble(m+1) k = one / dble(n+1) do 5 i = 1,m w(i) = zero 5 continue t = zero c do 30 j = 1,n t = t+k s = zero do 10 i = 1,j s = s+h w(i) = w(i) + k*s*(t-one)*x(j) 10 continue do 20 i = j+1,m s = s+h w(i) = w(i) + k*t*(s-one)*x(j) 20 continue 30 continue c return end c c------------------------------------------------------------------- c subroutine atv (m, n, w, y) c c computes y <- A'*w c integer m, n, i, j Double precision & w(m), y(n), one, zero, h, k, s, t parameter ( one = 1.0D+0, zero = 0.0D+0 ) c h = one / dble(m+1) k = one / dble(n+1) do 5 i = 1,n y(i) = zero 5 continue t = zero c do 30 j = 1,n t = t+k s = zero do 10 i = 1,j s = s+h y(j) = y(j) + k*s*(t-one)*w(i) 10 continue do 20 i = j+1,m s = s+h y(j) = y(j) + k*t*(s-one)*w(i) 20 continue 30 continue c return end c arpack-akloeckner-07/EXAMPLES/SVD/ssvd.f0000644000175000017500000005247407172772613017523 0ustar andreasandreas program ssvd c c This example program is intended to illustrate the c the use of ARPACK to compute the Singular Value Decomposition. c c This code shows how to use ARPACK to find a few of the c largest singular values(sigma) and corresponding right singular c vectors (v) for the the matrix A by solving the symmetric problem: c c (A'*A)*v = sigma*v c c where A is an m by n real matrix. c c This code may be easily modified to estimate the 2-norm c condition number largest(sigma)/smallest(sigma) by setting c which = 'BE' below. This will ask for a few of the smallest c and a few of the largest singular values simultaneously. c The condition number could then be estimated by taking c the ratio of the largest and smallest singular values. c c This formulation is appropriate when m .ge. n. c Reverse the roles of A and A' in the case that m .le. n. c c The main points illustrated here are c c 1) How to declare sufficient memory to find NEV c largest singular values of A . c c 2) Illustration of the reverse communication interface c needed to utilize the top level ARPACK routine SSAUPD c that computes the quantities needed to construct c the desired singular values and vectors(if requested). c c 3) How to extract the desired singular values and vectors c using the ARPACK routine SSEUPD. c c 4) How to construct the left singular vectors U from the c right singular vectors V to obtain the decomposition c c A*V = U*S c c where S = diag(sigma_1, sigma_2, ..., sigma_k). c c The only thing that must be supplied in order to use this c routine on your problem is to change the array dimensions c appropriately, to specify WHICH singular values you want to c compute and to supply a the matrix-vector products c c w <- Ax c y <- A'w c c in place of the calls to AV( ) and ATV( ) respectively below. c c Further documentation is available in the header of DSAUPD c which may be found in the SRC directory. c c This codes implements c c\Example-1 c ... Suppose we want to solve A'A*v = sigma*v in regular mode, c where A is derived from the simplest finite difference c discretization of the 2-dimensional kernel K(s,t)dt where c c K(s,t) = s(t-1) if 0 .le. s .le. t .le. 1, c t(s-1) if 0 .le. t .lt. s .le. 1. c c See subroutines AV and ATV for details. c ... OP = A'*A and B = I. c ... Assume "call av (n,x,y)" computes y = A*x c ... Assume "call atv (n,y,w)" computes w = A'*y c ... Assume exact shifts are used c ... c c\BeginLib c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c sscal Level 1 BLAS thst computes x <- x*alpha. c scopy Level 1 BLAS thst computes y <- x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: svd.F SID: 2.4 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c c %------------------------------------------------------% c | Storage Declarations: | c | | c | It is assumed that A is M by N with M .ge. N. | c | | c | The maximum dimensions for all arrays are | c | set here to accommodate a problem size of | c | M .le. MAXM and N .le. MAXN | c | | c | The NEV right singular vectors will be computed in | c | the N by NCV array V. | c | | c | The NEV left singular vectors will be computed in | c | the M by NEV array U. | c | | c | NEV is the number of singular values requested. | c | See specifications for ARPACK usage below. | c | | c | NCV is the largest number of basis vectors that will | c | be used in the Implicitly Restarted Arnoldi | c | Process. Work per major iteration is | c | proportional to N*NCV*NCV. | c | | c | You must set: | c | | c | MAXM: Maximum number of rows of the A allowed. | c | MAXN: Maximum number of columns of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %------------------------------------------------------% c integer maxm, maxn, maxnev, maxncv, ldv, ldu parameter (maxm = 500, maxn=250, maxnev=10, maxncv=25, & ldu = maxm, ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Real & v(ldv,maxncv), u(ldu, maxnev), & workl(maxncv*(maxncv+8)), workd(3*maxn), & s(maxncv,2), resid(maxn), ax(maxm) logical select(maxncv) integer iparam(11), ipntr(11) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, m, n, nev, ncv, lworkl, info, ierr, & j, ishfts, maxitr, mode1, nconv logical rvec Real & tol, sigma, temp c c %------------% c | Parameters | c %------------% c Real & one, zero parameter (one = 1.0E+0, zero = 0.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & snrm2 external snrm2, saxpy, scopy, sscal c c %-----------------------% c | Executable Statements | c %-----------------------% c c %-------------------------------------------------% c | The following include statement and assignments | c | initiate trace output from the internal | c | actions of ARPACK. See debug.doc in the | c | DOCUMENTS directory for usage. Initially, the | c | most useful information will be a breakdown of | c | time spent in the various stages of computation | c | given by setting msaupd = 1. | c %-------------------------------------------------% c include 'debug.h' ndigit = -3 logfil = 6 msgets = 0 msaitr = 0 msapps = 0 msaupd = 1 msaup2 = 0 mseigt = 0 mseupd = 0 c c %-------------------------------------------------% c | The following sets dimensions for this problem. | c %-------------------------------------------------% c m = 500 n = 100 c c %------------------------------------------------% c | Specifications for ARPACK usage are set | c | below: | c | | c | 1) NEV = 4 asks for 4 singular values to be | c | computed. | c | | c | 2) NCV = 20 sets the length of the Arnoldi | c | factorization | c | | c | 3) This is a standard problem | c | (indicated by bmat = 'I') | c | | c | 4) Ask for the NEV singular values of | c | largest magnitude | c | (indicated by which = 'LM') | c | See documentation in SSAUPD for the | c | other options SM, BE. | c | | c | Note: NEV and NCV must satisfy the following | c | conditions: | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %------------------------------------------------% c nev = 4 ncv = 10 bmat = 'I' which = 'LM' c if ( n .gt. maxn ) then print *, ' ERROR with _SVD: N is greater than MAXN ' go to 9000 else if ( m .gt. maxm ) then print *, ' ERROR with _SVD: M is greater than MAXM ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SVD: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SVD: NCV is greater than MAXNCV ' go to 9000 end if c c %-----------------------------------------------------% c | Specification of stopping rules and initial | c | conditions before calling SSAUPD | c | | c | abs(sigmaC - sigmaT) < TOL*abs(sigmaC) | c | computed true | c | | c | If TOL .le. 0, then TOL <- macheps | c | (machine precision) is used. | c | | c | IDO is the REVERSE COMMUNICATION parameter | c | used to specify actions to be taken on return | c | from SSAUPD. (See usage below.) | c | | c | It MUST initially be set to 0 before the first | c | call to SSAUPD. | c | | c | INFO on entry specifies starting vector information | c | and on return indicates error codes | c | | c | Initially, setting INFO=0 indicates that a | c | random starting vector is requested to | c | start the ARNOLDI iteration. Setting INFO to | c | a nonzero value on the initial call is used | c | if you want to specify your own starting | c | vector (This vector must be placed in RESID.) | c | | c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. | c %-----------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero info = 0 ido = 0 c c %---------------------------------------------------% c | Specification of Algorithm Mode: | c | | c | This program uses the exact shift strategy | c | (indicated by setting IPARAM(1) = 1.) | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of SSAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | SSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = n mode1 = 1 c iparam(1) = ishfts c iparam(3) = maxitr c iparam(7) = mode1 c c %------------------------------------------------% c | M A I N L O O P (Reverse communication loop) | c %------------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call ssaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %---------------------------------------% c | Perform matrix vector multiplications | c | w <--- A*x (av()) | c | y <--- A'*w (atv()) | c | The user should supply his/her own | c | matrix vector multiplication routines | c | here that takes workd(ipntr(1)) as | c | the input, and returns the result in | c | workd(ipntr(2)). | c %---------------------------------------% c call av (m, n, workd(ipntr(1)), ax) call atv (m, n, ax, workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in SSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ', info print *, ' Check documentation in _saupd ' print *, ' ' c else c c %--------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SSEUPD. | c | | c | Computed singular values may be extracted. | c | | c | Singular vectors may also be computed now | c | if desired. (indicated by rvec = .true.) | c | | c | The routine SSEUPD now called to do this | c | post processing | c %--------------------------------------------% c rvec = .true. c call sseupd ( rvec, 'All', select, s, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %-----------------------------------------------% c | Singular values are returned in the first | c | column of the two dimensional array S | c | and the corresponding right singular vectors | c | are returned in the first NEV columns of the | c | two dimensional array V as requested here. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c s(j,1) = sqrt(s(j,1)) c c %-----------------------------% c | Compute the left singular | c | vectors from the formula | c | | c | u = Av/sigma | c | | c | u should have norm 1 so | c | divide by norm(Av) instead. | c %-----------------------------% c call av(m, n, v(1,j), ax) call scopy(m, ax, 1, u(1,j), 1) temp = one/snrm2(m, u(1,j), 1) call sscal(m, temp, u(1,j), 1) c c %---------------------------% c | | c | Compute the residual norm | c | | c | || A*v - sigma*u || | c | | c | for the NCONV accurately | c | computed singular values | c | and vectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance). | c | Store the result in 2nd | c | column of array S. | c %---------------------------% c call saxpy(m, -s(j,1), u(1,j), 1, ax, 1) s(j,2) = snrm2(m, ax, 1) c 20 continue c c %-------------------------------% c | Display computed residuals | c %-------------------------------% c call smout(6, nconv, 2, s, maxncv, -6, & 'Singular values and direct residuals') end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SVD ' print *, ' ==== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %-------------------------% c | Done with program ssvd. | c %-------------------------% c 9000 continue c end c c ------------------------------------------------------------------ c matrix vector subroutines c c The matrix A is derived from the simplest finite difference c discretization of the integral operator c c f(s) = integral(K(s,t)x(t)dt). c c Thus, the matrix A is a discretization of the 2-dimensional kernel c K(s,t)dt, where c c K(s,t) = s(t-1) if 0 .le. s .le. t .le. 1, c t(s-1) if 0 .le. t .lt. s .le. 1. c c Thus A is an m by n matrix with entries c c A(i,j) = k*(si)*(tj - 1) if i .le. j, c k*(tj)*(si - 1) if i .gt. j c c where si = i/(m+1) and tj = j/(n+1) and k = 1/(n+1). c c------------------------------------------------------------------- c subroutine av (m, n, x, w) c c computes w <- A*x c integer m, n, i, j Real & x(n), w(m), one, zero, h, k, s, t parameter ( one = 1.0E+0, zero = 0.0E+0 ) c h = one / real(m+1) k = one / real(n+1) do 5 i = 1,m w(i) = zero 5 continue t = zero c do 30 j = 1,n t = t+k s = zero do 10 i = 1,j s = s+h w(i) = w(i) + k*s*(t-one)*x(j) 10 continue do 20 i = j+1,m s = s+h w(i) = w(i) + k*t*(s-one)*x(j) 20 continue 30 continue c return end c c------------------------------------------------------------------- c subroutine atv (m, n, w, y) c c computes y <- A'*w c integer m, n, i, j Real & w(m), y(n), one, zero, h, k, s, t parameter ( one = 1.0E+0, zero = 0.0E+0 ) c h = one / real(m+1) k = one / real(n+1) do 5 i = 1,n y(i) = zero 5 continue t = zero c do 30 j = 1,n t = t+k s = zero do 10 i = 1,j s = s+h y(j) = y(j) + k*s*(t-one)*w(i) 10 continue do 20 i = j+1,m s = s+h y(j) = y(j) + k*t*(s-one)*w(i) 20 continue 30 continue c return end c arpack-akloeckner-07/EXAMPLES/SVD/makefile0000644000175000017500000000055006221772231020047 0ustar andreasandreas# # makefile to run simple examples of the reverse communication # protocol. # # Modify if ARPACK library was built somewhere else. # #\SCCS Information: @(#) # FILE: makefile SID: 2.2 DATE OF SID: 9/24/96 RELEASE: 2 # include ../../ARmake.inc ssvd: ssvd.o $(FC) $(FFLAGS) ssvd.o $(ALIBS) -o ssvd dsvd: dsvd.o $(FC) $(FFLAGS) dsvd.o $(ALIBS) -o dsvd arpack-akloeckner-07/EXAMPLES/SVD/README0000644000175000017500000000112406053173421017224 0ustar andreasandreas1. Purpose ------- This directory contains simple example drivers that call ARPACK subroutine [s,d]saupd.f and [s,d]seupd.f to compute the Singular Value Decomposition of a matrix A. These drivers illustrate how to use ARPACK in considerable detail. 2. Naming Convention ----------------- The name for each driver has the form 'Xsvd.f', where X - is 's' (single precision) or 'd' (double precision) 3. Usage ----- To run these drivers, you may use the makefile in this directory and issue, for example, "make ssvd". Then execute using "ssvd". arpack-akloeckner-07/EXAMPLES/SVD/debug.h0000644000175000017500000000135106053174501017605 0ustar andreasandreasc c\SCCS Information: @(#) c FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 c c %---------------------------------% c | See debug.doc for documentation | c %---------------------------------% integer logfil, ndigit, mgetv0, & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd common /debug/ & logfil, ndigit, mgetv0, & msaupd, msaup2, msaitr, mseigt, msapps, msgets, mseupd, & mnaupd, mnaup2, mnaitr, mneigh, mnapps, mngets, mneupd, & mcaupd, mcaup2, mcaitr, mceigh, mcapps, mcgets, mceupd arpack-akloeckner-07/EXAMPLES/README0000644000175000017500000001062306137041604016574 0ustar andreasandreas1. Purpose ------- This directory contains example drivers that call ARPACK subroutines __aupd.f and __eupd.f to solve various eigenvalue problems using regular, shift-invert or other special modes (such as Cayley, Bucking etc.) These drivers illustrate how to set various ARPACK parameters to solve different problems in different modes. They provide a guideline on how to use ARPACK's reverse communication interface. The user may modify any one of these drivers, and supply his/her own matrix vector multiplication routine to solve the problem of his/her own interest. These drivers are installed in the following subdirectories. SIMPLE --- simple drivers for beginners. SYM --- drivers for symmetric eigenvalue problems NONSYM --- drivers for nonsymmetric eigenvalue problems COMPLEX --- drivers for eigenvalue problem with complex matrices BAND --- drivers for eigenvalue problem with BANDED matrices SVD --- drivers for computing singular values and vectors of a m by n matrix. 2. Getting started --------------- If you have never used ARPACK before, it might be a good idea to go into the subdirectory SIMPLE, and read one of the simple drivers [s,d]ssimp.f, [s,d]nsimp.f [c,z]nsimp.f first. The documentation explains how to use ARPACK in considerable detail. To run these drivers, you may use the makefile in that directory and issue, for example, "make sssimp", and then execute using "sssimp" The output should look like: _saupd: number of update iterations taken ----------------------------------------- 1 - 1: 5 _saupd: number of "converged" Ritz values ----------------------------------------- 1 - 1: 4 _saupd: final Ritz values ------------------------- 1 - 4: 8.912E+02 9.198E+02 9.198E+02 9.484E+02 _saupd: corresponding error bounds ---------------------------------- 1 - 4: 4.686E-11 1.905E-08 1.050E-10 5.700E-19 ========================================== = Symmetric implicit Arnoldi update code = = Version Number: 2.1 = = Version Date: 11/15/95 = ========================================== = Summary of timing statistics = ========================================== Total number update iterations = 5 Total number of OP*x operations = 78 Total number of B*x operations = 0 Total number of reorthogonalization steps = 78 Total number of iterative refinement steps = 0 Total number of restart steps = 0 Total time in user OP*x operation = 0.066667 Total time in user B*x operation = 0.000000 Total time in Arnoldi update routine = 1.166667 Total time in ssaup2 routine = 1.166667 Total time in basic Arnoldi iteration loop = 0.216667 Total time in reorthogonalization phase = 0.066667 Total time in (re)start vector generation = 0.000000 Total time in trid eigenvalue subproblem = 0.050000 Total time in getting the shifts = 0.000000 Total time in applying the shifts = 0.900000 Total time in convergence testing = 0.000000 Ritz values and relative residuals ---------------------------------- Col 1 Col 2 Row 1: 8.91167E+02 6.95597E-07 Row 2: 9.19781E+02 3.30156E-07 Row 3: 9.19781E+02 4.25717E-07 Row 4: 9.48395E+02 3.20519E-07 _SSIMP ====== Size of the matrix is 100 The number of Ritz values requested is 4 The number of Arnoldi vectors generated (NCV) is 20 What portion of the spectrum: LM The number of converged Ritz values is 4 The number of Implicit Arnoldi update iterations taken is 5 The number of OP*x is 78 The convergence criterion is 5.96046E-08 3. Convention ---------- The naming convention for each driver is explained in the README file in each subdirectory. 4. LAPACK & BLAS routines ---------------------- All ARPACK codes assume the use of LAPACK version 2.0 codes. LAPACK and BLAS routines needed for each driver program are listed at the beginning of the documentation in each driver program. arpack-akloeckner-07/EXAMPLES/NONSYM/0000755000175000017500000000000007172776557016763 5ustar andreasandreasarpack-akloeckner-07/EXAMPLES/NONSYM/README0000644000175000017500000000421706053471237017627 0ustar andreasandreas1. Purpose ------- This directory contains example drivers that call ARPACK subroutines [s,d]naupd.f and [s,d]neupd.f to solve real NONSYMMETRIC eigenvalue problems using regular, inverse or shift-invert modes. These drivers illustrate how to set various ARPACK parameters to solve different problems in different modes. They provide a guideline on how to use ARPACK's reverse communication interface. The user may modify any one of these drivers, and provide his/her own matrix vector multiplication routine to solve the problem of his/her own interest. 2. Naming convention ----------------- The name for each driver has the form 'XndrvN.f', where X - is 's' (single precision) or 'd' (double precision) N - is a number between 1 and 6. If N = 1, the driver solves a STANDARD eigenvalue problem in REGULAR mode. N = 2, the driver solves a STANDARD eigenvalue problem in SHIFT-INVERT mode with a REAL shift. N = 3, the driver solves a GENERALIZED eigenvalue problem in INVERSE mode. N = 4, the driver solves a GENERALIZED eigenvalue problem in SHIFT-INVERT mode with a REAL shift. These are 4 commonly used drivers. For shift-invert (N=2,4) mode the user needs to supply a linear system solver to perform y=inv[A-sigma*B]*x. If N > 4, shift-invert is used with a complex shift whose imaginary part is nonzero. If N = 5, the driver solves a GENERALIZED eigenvalue problem using mode 3 of [s,d]naupd. N = 6. the driver solves a GENERALIZED eigenvalue problem using mode 4 of [s,d]naupd. These two drivers require the user to provide COMPLEX arithmetic linear system solver. For more information on the use of complex shift, see the following reference: B.N. Parlett & Y. Saad, "Complex Shift and Invert Strategies for Real Matrices", Linear Algebra and its Applications, vol 88/89, pp 575-595, (1987). 3. Usage ----- To run these drivers, you may use the makefile in this directory and issue, for example, "make sndrv1". Then execute using "sndrv1". arpack-akloeckner-07/EXAMPLES/NONSYM/dndrv1.f0000644000175000017500000004037507172775512020327 0ustar andreasandreas program dndrv1 c c c Example program to illustrate the idea of reverse communication c for a standard nonsymmetric eigenvalue problem. c c We implement example one of ex-nonsym.doc in DOCUMENTS directory c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is obtained from the standard central difference c discretization of the convection-diffusion operator c (Laplacian u) + rho*(du / dx) c on the unit square [0,1]x[0,1] with zero Dirichlet boundary c condition. c c ... OP = A and B = I. c c ... Assume "call av (nx,x,y)" computes y = A*x.c c c ... Use mode 1 of DNAUPD. c c\BeginLib c c\Routines called: c dnaupd ARPACK reverse communication interface routine. c dneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv1.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c--------------------------------------------------------------------------- c c %-----------------------------% c | Define maximum dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=12, maxncv=30, ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Double precision & ax(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nx, nev, ncv, lworkl, info, j, & ierr, nconv, maxitr, ishfts, mode Double precision & tol, sigmar, sigmai logical first, rvec c c %------------% c | Parameters | c %------------% c Double precision & zero parameter (zero = 0.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dlapy2, dnrm2 external dlapy2, dnrm2, daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV, WHICH to solve problems of | c | different sizes, and to get different parts of | c | the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'SM' c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of DNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | DNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 1 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dnaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform matrix vector multiplication | c | y <--- OP*x | c | The user should supply his/her own | c | matrix vector multiplication routine here | c | that takes workd(ipntr(1)) as the input | c | vector, and return the matrix vector | c | product to workd(ipntr(2)). | c %-------------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call dneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the imaginary part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(nx, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex. | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(nx, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) call daxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) call av(nx, v(1,j+1), ax) call daxpy(n, -d(j,2), v(1,j), 1, ax, 1) call daxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV1 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dndrv1. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector subroutine c c The matrix used is the 2 dimensional convection-diffusion c operator discretized using central difference. c subroutine av (nx, v, w) integer nx, j, lo Double precision & v(nx*nx), w(nx*nx), one, h2 parameter (one = 1.0D+0) external daxpy c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c derived from the standard central difference discretization c of the 2 dimensional convection-diffusion operator c (Laplacian u) + rho*(du/dx) on a unit square with zero boundary c condition. c c When rho*h/2 <= 1, the discrete convection-diffusion operator c has real eigenvalues. When rho*h/2 > 1, it has COMPLEX c eigenvalues. c c The subroutine TV is called to compute y<---T*x. c c h2 = one / dble((nx+1)*(nx+1)) c call tv(nx,v(1),w(1)) call daxpy(nx, -one/h2, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call daxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) call daxpy(nx, -one/h2, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call daxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) c return end c========================================================================= subroutine tv (nx, x, y) c integer nx, j Double precision & x(nx), y(nx), h, h2, dd, dl, du c Double precision & one, zero, rho parameter (one = 1.0D+0, zero = 0.0D+0, & rho = 0.0D+0) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal. c c When rho*h/2 <= 1, the discrete convection-diffusion operator c has real eigenvalues. When rho*h/2 > 1, it has COMPLEX c eigenvalues. c h = one / dble(nx+1) h2 = h*h dd = 4.0D+0 / h2 dl = -one / h2 - 5.0D-1*rho / h du = -one / h2 + 5.0D-1*rho / h c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/NONSYM/dndrv2.f0000644000175000017500000003756107172775624020337 0ustar andreasandreas program dndrv2 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a standard nonsymmetric eigenvalue problem. c c We implement example two of ex-nonsym.doc in DOCUMENTS directory c c\Example-2 c ... Suppose we want to solve A*x = lambda*x in shift-invert mode, c where A is derived from the centered difference discretization c of the 1-dimensional convection-diffusion operator c (d^2u / dx^2) + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition. c c ... The shift sigma is a real number. c c ... OP = inv[A-sigma*I] and B = I. c c ... Use mode 3 of DNAUPD. c c\BeginLib c c\Routines called: c dnaupd ARPACK reverse communication interface routine. c dneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgttrf LAPACK tridiagonal factorization routine. c dgttrs LAPACK tridiagonal solve routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dcopy Level 1 BLAS that copies one vector to another. c ddot Level 1 BLAS that computes the dot product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv2.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Double precision & ax(maxn), d(maxncv,3), resid(maxn), & v(ldv, maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv), & dd(maxn), dl(maxn), du(maxn), & du2(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, & ierr, nconv, maxitr, ishfts, mode Double precision & tol, h, s, & sigmar, sigmai, s1, s2, s3 logical first, rvec c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two, rho common /convct/ rho parameter (one = 1.0D+0, zero = 0.0D+0, & two = 2.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & ddot, dnrm2, dlapy2 external dgttrf, dgttrs, ddot, dnrm2, dlapy2 c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | standard eigenvalue problem is solved (BMAT = | c | 'I'). NEV is the number of eigenvalues (closest | c | to the shift SIGMAR) to be approximated. Since | c | the shift-invert mode is used, WHICH is set to | c | 'LM'. The user can modify NEV, NCV, SIGMAR to | c | solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigmar = 1.0D+0 sigmai = 0.0D+0 c c %----------------------------------------------------% c | Construct C = A - SIGMA*I in real arithmetic, and | c | factor C in real arithmetic using LAPACK | c | subroutine dgttrf. The matrix A is chosen to be | c | the tridiagonal matrix derived from standard | c | central difference of the 1-d convection diffusion | c | operator u" + rho*u' on the interval [0, 1] with | c | zero Dirichlet boundary condition. | c %----------------------------------------------------% c rho = 1.0D+1 h = one / dble(n+1) s = rho*h / two c s1 = -one-s s2 = two - sigmar s3 = -one+s c do 10 j = 1, n-1 dl(j) = s1 dd(j) = s2 du(j) = s3 10 continue dd(n) = s2 c call dgttrf(n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV2.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of DNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details see the | c | documentation in DNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine DNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dnaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if ( ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*I]*x | c | The user should supply his/her own linear | c | system solver here that takes | c | workd(ipntr(1)) as the input, and returns | c | the result to workd(ipntr(2)). | c %-------------------------------------------% c call dcopy( n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) c call dgttrs('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV2.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation in _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call dneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the imaginary part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) call daxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) call av(n, v(1,j+1), ax) call daxpy(n, -d(j,2), v(1,j), 1, ax, 1) call daxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 30 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV2 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dndrv2. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------- c c matrix vector multiplication subroutine c subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), rho, two, one, dd, dl, du, s, h common /convct/ rho parameter (one = 1.0D+0, two = 2.0D+0 ) c c Compute the matrix vector multiplication y<---A*x c where A is a n by n nonsymmetric tridiagonal matrix derived from c the central difference discretization of the 1-dimensional c convection diffusion operator on the interval [0,1] with c zero Dirichlet boundary condition. c c h = one / dble(n+1) s = rho *h / two dd = two dl = -one - s du = -one + s c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end arpack-akloeckner-07/EXAMPLES/NONSYM/dndrv3.f0000644000175000017500000004135607172775720020332 0ustar andreasandreas program dndrv3 c c Simple program to illustrate the idea of reverse communication c in inverse mode for a generalized nonsymmetric eigenvalue problem. c c We implement example three of ex-nonsym.doc in DOCUMENTS directory c c\Example-3 c ... Suppose we want to solve A*x = lambda*B*x in inverse mode, c where A and B are derived from the finite element discretization c of the 1-dimensional convection-diffusion operator c (d^2u / dx^2) + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition c using linear elements. c c ... So OP = inv[M]*A and B = M. c c ... Use mode 2 of DNAUPD. c c\BeginLib c c\Routines called: c dnaupd ARPACK reverse communication interface routine. c dneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dpttrf LAPACK symmetric positive definite tridiagonal factorization c routine. c dpttrs LAPACK symmetric positive definite tridiagonal solve routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv3.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Double precision & ax(maxn), mx(maxn), d(maxncv, 3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv), & md(maxn), me(maxn-1) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Double precision & tol, sigmar, sigmai, h logical first, rvec c c %------------% c | Parameters | c %------------% c Double precision & zero, one parameter (zero = 0.0D+0, one = 1.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% Double precision & dnrm2, dlapy2 external daxpy, dnrm2, dpttrf, dpttrs, dlapy2 c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues to be | c | approximated. The user can modify NEV, NCV, WHICH | c | to solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' c c %------------------------------------------------% c | M is the mass matrix formed by using piecewise | c | linear elements on [0,1]. | c %------------------------------------------------% c h = one / dble(n+1) do 20 j = 1, n-1 md(j) = 4.0D+0*h me(j) = one*h 20 continue md(n) = 4.0D+0*h c call dpttrf(n, md, me, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _pttrf. ' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of DNAUPD is used | c | (IPARAM(7) = 2). All these options can be | c | changed by the user. For details, see the | c | documentation in DNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 2 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dnaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %----------------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c | The user should supply his/her own | c | matrix vector routine and a linear | c | system solver. The matrix-vector | c | subroutine should take workd(ipntr(1)) | c | as input, and the final result should | c | be returned to workd(ipntr(2)). | c %----------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call dpttrs(n, 1, md, me, workd(ipntr(2)), n, & ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _pttrs. ' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 10 c else if ( ido .eq. 2) then c c %-------------------------------------% c | Perform y <--- M*x | c | The matrix vector multiplication | c | routine should take workd(ipntr(1)) | c | as input and return the result to | c | workd(ipntr(2)). | c %-------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 10 c end if c c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in DNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. call dneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd' print *, ' ' c else c first = .true. nconv = iparam(5) do 30 j=1, iparam(5) c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*M*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j+1), mx) call daxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1)**2 call av(n, v(1,j+1), ax) call mv(n, v(1,j+1), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j), mx) call daxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 30 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV3 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dndrv3. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), one, two, dd, dl, du, s, h, rho parameter ( rho = 1.0D+1, one = 1.0D+0, & two = 2.0D+0) c c Compute the matrix vector multiplication y<---A*x c where A is stiffness matrix obtained from the finite element c discretization of the 1-dimensional convection diffusion operator c d^2u/dx^2 + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition using c linear elements. c h = one / dble(n+1) s = rho / two dd = two / h dl = -one/h - s du = -one/h + s c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end c------------------------------------------------------------------------ subroutine mv (n, v, w) integer n, j Double precision & v(n), w(n), one, four, h parameter ( one = 1.0D+0, four = 4.0D+0) c c Compute the matrix vector multiplication y<---M*x c where M is the mass matrix formed by using piecewise linear c elements on [0,1]. c w(1) = four*v(1) + one*v(2) do 10 j = 2,n-1 w(j) = one*v(j-1) + four*v(j) + one*v(j+1) 10 continue w(n) = one*v(n-1) + four*v(n) c h = one / dble(n+1) call dscal(n, h, w, 1) return end arpack-akloeckner-07/EXAMPLES/NONSYM/dndrv4.f0000644000175000017500000004644007172772330020324 0ustar andreasandreas program dndrv4 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a generalized nonsymmetric eigenvalue c problem. c c We implement example four of ex-nonsym.doc in DOCUMENTS directory c c\Example-4 c ... Suppose we want to solve A*x = lambda*B*x in inverse mode, c where A and B are derived from the finite element discretization c of the 1-dimensional convection-diffusion operator c (d^2u / dx^2) + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition c using linear elements. c c ... The shift sigma is a real number. c c ... OP = inv[A-SIGMA*M]*M and B = M. c c ... Use mode 3 of DNAUPD. c c\BeginLib c c\Routines called: c dnaupd ARPACK reverse communication interface routine. c dneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgttrf LAPACK tridiagonal factorization routine. c dgttrs LAPACK tridiagonal linear system solve routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dcopy Level 1 BLAS that copies one vector to another. c ddot Level 1 BLAS that computes the dot product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv4.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c----------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Double precision & ax(maxn), mx(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv), & dd(maxn), dl(maxn), du(maxn), & du2(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Double precision & tol, h, s, & sigmar, sigmai, s1, s2, s3 logical first, rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & ddot, dnrm2, dlapy2 external ddot, dnrm2, dlapy2, dgttrf, dgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %------------% c | Parameters | c %------------% c Double precision & one, zero, two, six, rho common /convct/ rho parameter (one = 1.0D+0, zero = 0.0D+0, & two = 2.0D+0, six = 6.0D+0) c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues (closest | c | to SIGMAR) to be approximated. Since the | c | shift-invert mode is used, WHICH is set to 'LM'. | c | The user can modify NEV, NCV, SIGMAR to solve | c | problems of different sizes, and to get different | c | parts of the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = one sigmai = zero c c %--------------------------------------------------% c | Construct C = A - SIGMA*M in real arithmetic, | c | and factor C in real arithmetic (using LAPACK | c | subroutine dgttrf). The matrix A is chosen to be | c | the tridiagonal matrix derived from the standard | c | central difference discretization of the 1-d | c | convection-diffusion operator u" + rho*u' on the | c | interval [0, 1] with zero Dirichlet boundary | c | condition. The matrix M is the mass matrix | c | formed by using piecewise linear elements on | c | [0,1]. | c %--------------------------------------------------% c rho = 1.0D+1 h = one / dble(n+1) s = rho / two c s1 = -one/h - s - sigmar*h/six s2 = two/h - 4.0D+0*sigmar*h/six s3 = -one/h + s - sigmar*h/six c do 10 j = 1, n-1 dl(j) = s1 dd(j) = s2 du(j) = s3 10 continue dd(n) = s2 c call dgttrf(n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of DNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details, see the | c | documentation in DNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------% c | M A I N L O O P(Reverse communication) | c %------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine DNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dnaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, info ) c if (ido .eq. -1) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*M]*M*x | c | to force starting vector into the range | c | of OP. The user should supply his/her | c | own matrix vector multiplication routine | c | and a linear system solver. The matrix | c | vector multiplication routine should take | c | workd(ipntr(1)) as the input. The final | c | result should be returned to | c | workd(ipntr(2)). | c %-------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) call dgttrs('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 1) then c c %-----------------------------------------% c | Perform y <-- OP*x = inv[A-sigma*M]*M*x | c | M*x has been saved in workd(ipntr(3)). | c | The user only need the linear system | c | solver here that takes workd(ipntr(3)) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call dcopy( n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call dgttrs ('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- M*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation in _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. call dneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex. | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j+1), mx) call daxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) call av(n, v(1,j+1), ax) call mv(n, v(1,j+1), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j), mx) call daxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 30 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV4 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dndrv4. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine mv (n, v, w) integer n, j Double precision & v(n), w(n), one, four, six, h parameter (one = 1.0D+0, four = 4.0D+0, six = 6.0D+0) c c Compute the matrix vector multiplication y<---M*x c where M is mass matrix formed by using piecewise linear elements c on [0,1]. c w(1) = ( four*v(1) + one*v(2) ) / six do 10 j = 2,n-1 w(j) = ( one*v(j-1) + four*v(j) + one*v(j+1) ) / six 10 continue w(n) = ( one*v(n-1) + four*v(n) ) / six c h = one / dble(n+1) call dscal(n, h, w, 1) return end c------------------------------------------------------------------ subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), one, two, dd, dl, du, s, h, rho common /convct/ rho parameter (one = 1.0D+0, two = 2.0D+0) c c Compute the matrix vector multiplication y<---A*x c where A is obtained from the finite element discretization of the c 1-dimensional convection diffusion operator c d^u/dx^2 + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition c using linear elements. c This routine is only used in residual calculation. c h = one / dble(n+1) s = rho / two dd = two / h dl = -one/h - s du = -one/h + s c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end arpack-akloeckner-07/EXAMPLES/NONSYM/dndrv5.f0000644000175000017500000005330507172776123020327 0ustar andreasandreas program dndrv5 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a generalized nonsymmetric eigenvalue problem. c c We implement example five of ex-nonsym.doc in DOCUMENTS directory c c\Example-5 c c ... Suppose we want to solve A*x = lambda*B*x in shift-invert mode c The matrix A is the tridiagonal matrix with 2 on the diagonal, c -2 on the subdiagonal and 3 on the superdiagonal. The matrix M c is the tridiagonal matrix with 4 on the diagonal and 1 on the c off-diagonals. c ... The shift sigma is a complex number (sigmar, sigmai). c ... OP = Real_Part{inv[A-(SIGMAR,SIGMAI)*M]*M and B = M. c ... Use mode 3 of DNAUPD. c c\BeginLib c c\Routines called: c dnaupd ARPACK reverse communication interface routine. c dneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c zgttrf LAPACK complex matrix factorization routine. c zgttrs LAPACK complex linear system solve routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c ddot Level 1 BLAS that computes the dot product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector c av Matrix vector subroutine that computes A*x. c mv Matrix vector subroutine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv5.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Double precision & ax(maxn), mx(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv) Complex*16 & cdd(maxn), cdl(maxn), cdu(maxn), & cdu2(maxn), ctemp(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Double precision & tol, numr, numi, denr, deni, sigmar, sigmai Complex*16 & c1, c2, c3 logical first, rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c external zgttrf, zgttrs Double precision & ddot, dnrm2, dlapy2 external ddot, dnrm2, dlapy2 c c c %------------% c | Parameters | c %------------% c Double precision & zero parameter (zero = 0.0D+0) c c %--------------------% c | Intrinsic Function | c %--------------------% c intrinsic dble, dcmplx, abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues (closest | c | to the shift (SIGMAR,SIGMAI)) to be approximated. | c | Since the shift-invert mode is used, WHICH is set | c | to 'LM'. The user can modify NEV, NCV, SIGMAR, | c | SIGMAI to solve problems of different sizes, and | c | to get different parts of the spectrum. However, | c | The following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV5: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV5: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV5: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = 4.0D-1 sigmai = 6.0D-1 c c %---------------------------------------------------% c | Construct C = A - (SIGMAR,SIGMAI)*M in complex | c | arithmetic, and factor C in complex arithmetic | c | (using LAPACK subroutine zgttrf). The matrix A is | c | chosen to be the tridiagonal matrix with -2 on | c | the subdiagonal, 2 on the diagonal and 3 on the | c | superdiagonal. The matrix M is chosen to the | c | symmetric tridiagonal matrix with 4 on the | c | diagonal and 1 on the off-diagonals. | c %---------------------------------------------------% c c1 = dcmplx(-2.0D+0-sigmar, -sigmai) c2 = dcmplx( 2.0D+0-4.0D+0*sigmar, -4.0D+0*sigmai) c3 = dcmplx( 3.0D+0-sigmar, -sigmai) c do 10 j = 1, n-1 cdl(j) = c1 cdd(j) = c2 cdu(j) = c3 10 continue cdd(n) = c2 c call zgttrf(n, cdl, cdd, cdu, cdu2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV5.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shift with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of DNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details, see the | c | documentation in DNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------% c | M A I N L O O P(Reverse communication) | c %------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine DNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dnaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, info ) c if (ido .eq. -1) then c c %-------------------------------------------------------% c | Perform | c | y <--- OP*x = Real_Part{inv[A-(SIGMAR,SIGMAI)*M]*M*x} | c | to force starting vector into the range of OP. The | c | user should supply his/her own matrix vector | c | multiplication routine and a complex linear system | c | solver. The matrix vector multiplication routine | c | should take workd(ipntr(1)) as the input. The final | c | result (a real vector) should be returned to | c | workd(ipntr(2)). | c %-------------------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) do 30 j = 1, n ctemp(j) = dcmplx(workd(ipntr(2)+j-1)) 30 continue c call zgttrs('N', n, 1, cdl, cdd, cdu, cdu2, ipiv, & ctemp, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV5.' print*, ' ' go to 9000 end if do 40 j = 1, n workd(ipntr(2)+j-1) = dble(ctemp(j)) 40 continue c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 1) then c c %-------------------------------------------------------% c | Perform | c | y <--- OP*x = Real_Part{inv[A-(SIGMAR,SIGMAI)*M]*M*x} | c | M*x has been saved in workd(ipntr(3)). The user only | c | needs the complex linear system solver here that | c | takes complex[workd(ipntr(3))] as input, and returns | c | the result to workd(ipntr(2)). | c %-------------------------------------------------------% c do 50 j = 1,n ctemp(j) = dcmplx(workd(ipntr(3)+j-1)) 50 continue call zgttrs ('N', n, 1, cdl, cdd, cdu, cdu2, ipiv, & ctemp, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV5.' print*, ' ' go to 9000 end if do 60 j = 1, n workd(ipntr(2)+j-1) = dble(ctemp(j)) 60 continue c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- M*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c c %------------------------------------------% c | Either we have convergence, or there is | c | an error. | c %------------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd info = ',info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. call dneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 70 j=1,nconv c c %-------------------------------------% c | Use Rayleigh Quotient to recover | c | eigenvalues of the original problem.| c %-------------------------------------% c if ( d(j,2) .eq. zero ) then c c %---------------------------% c | Eigenvalue is real. | c | Compute d = x'(Ax)/x'(Mx).| c %---------------------------% c call av(n, v(1,j), ax ) numr = ddot(n, v(1,j), 1, ax, 1) call mv(n, v(1,j), ax ) denr = ddot(n, v(1,j), 1, ax, 1) d(j,1) = numr / denr c else if (first) then c c %------------------------% c | Eigenvalue is complex. | c | Compute the first one | c | of the conjugate pair. | c %------------------------% c c %----------------% c | Compute x'(Ax) | c %----------------% call av(n, v(1,j), ax ) numr = ddot(n, v(1,j), 1, ax, 1) numi = ddot(n, v(1,j+1), 1, ax, 1) call av(n, v(1,j+1), ax) numr = numr + ddot(n,v(1,j+1),1,ax,1) numi = -numi + ddot(n,v(1,j),1,ax,1) c c %----------------% c | Compute x'(Mx) | c %----------------% c call mv(n, v(1,j), ax ) denr = ddot(n, v(1,j), 1, ax, 1) deni = ddot(n, v(1,j+1), 1, ax, 1) call mv(n, v(1,j+1), ax) denr = denr + ddot(n,v(1,j+1),1,ax,1) deni = -deni + ddot(n,v(1,j),1, ax,1) c c %----------------% c | d=x'(Ax)/x'(Mx)| c %----------------% c d(j,1) = (numr*denr+numi*deni) / & dlapy2(denr, deni) d(j,2) = (numi*denr-numr*deni) / & dlapy2(denr, deni) first = .false. c else c c %------------------------------% c | Get the second eigenvalue of | c | the conjugate pair by taking | c | the conjugate of the last | c | eigenvalue computed. | c %------------------------------% c d(j,1) = d(j-1,1) d(j,2) = -d(j-1,2) first = .true. c end if c 70 continue c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c first = .true. do 80 j=1, nconv c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j+1), mx) call daxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) call av(n, v(1,j+1), ax) call mv(n, v(1,j+1), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j), mx) call daxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 80 continue c c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV5 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dndrv5. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine mv (n, v, w) integer n, j Double precision & v(n), w(n), one, four parameter (one = 1.0D+0, four = 4.0D+0) c c Compute the matrix vector multiplication y<---M*x c where M is a n by n symmetric tridiagonal matrix with 4 on the c diagonal, 1 on the subdiagonal and superdiagonal. c w(1) = four*v(1) + one*v(2) do 10 j = 2,n-1 w(j) = one*v(j-1) + four*v(j) + one*v(j+1) 10 continue w(n) = one*v(n-1) + four*v(n) return end c------------------------------------------------------------------ subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), three, two parameter (three = 3.0D+0, two = 2.0D+0) c c Compute the matrix vector multiplication y<---A*x c where M is a n by n symmetric tridiagonal matrix with 2 on the c diagonal, -2 on the subdiagonal and 3 on the superdiagonal. c w(1) = two*v(1) + three*v(2) do 10 j = 2,n-1 w(j) = -two*v(j-1) + two*v(j) + three*v(j+1) 10 continue w(n) = -two*v(n-1) + two*v(n) return end arpack-akloeckner-07/EXAMPLES/NONSYM/dndrv6.f0000644000175000017500000005350107172776274020335 0ustar andreasandreas program dndrv6 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a generalized nonsymmetric eigenvalue problem. c c We implement example six of ex-nonsym.doc in DOCUMENTS directory c c\Example-6 c c ... Suppose we want to solve A*x = lambda*B*x in shift-invert mode c The matrix A is the tridiagonal matrix with 2 on the diagonal, c -2 on the subdiagonal and 3 on the superdiagonal. The matrix M c is the tridiagonal matrix with 4 on the diagonal and 1 on the c off-diagonals. c ... The shift sigma is a complex number (sigmar, sigmai). c ... OP = Imaginary_Part{inv[A-(SIGMAR,SIGMAI)*M]*M and B = M. c ... Use mode 4 of DNAUPD. c c\BeginLib c c\Routines called: c dnaupd ARPACK reverse communication interface routine. c dneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c zgttrf LAPACK complex matrix factorization routine. c zgttrs LAPACK complex linear system solve routine. c dlapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c ddot Level 1 BLAS that computes the dot product of two vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector subroutine that computes A*x. c mv Matrix vector subroutine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv6.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Double precision & ax(maxn), mx(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv) Complex*16 & cdd(maxn), cdl(maxn), cdu(maxn), & cdu2(maxn), ctemp(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Double precision & tol, numr, numi, denr, deni, sigmar, sigmai Complex*16 & c1, c2, c3 logical first, rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c external zgttrf, zgttrs Double precision & ddot, dnrm2, dlapy2 external ddot, dnrm2, dlapy2 c c %------------% c | Parameters | c %------------% c Double precision & zero parameter (zero = 0.0D+0) c c %--------------------% c | Intrinsic Function | c %--------------------% c intrinsic dimag, dcmplx, abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues (closest | c | to the shift (SIGMAR,SIGMAI)) to be approximated. | c | Since the shift-invert mode is used, WHICH is set | c | to 'LM'. The user can modify NEV, NCV, SIGMA to | c | solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV6: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV6: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV6: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = 4.0D-1 sigmai = 6.0D-1 c c %----------------------------------------------------% c | Construct C = A - (SIGMAR,SIGMAI)*M in complex | c | arithmetic, and factor C in complex arithmetic | c | (using LAPACK subroutine zgttrf). The matrix A is | c | chosen to be the tridiagonal matrix with -2 on the | c | subdiagonal, 2 on the diagonal and 3 on the | c | superdiagonal. The matrix M is chosen to be the | c | symmetric tridiagonal matrix with 4 on the | c | diagonal and 1 on the off-diagonals. | c %----------------------------------------------------% c c1 = dcmplx(-2.0D+0-sigmar, -sigmai) c2 = dcmplx( 2.0D+0-4.0D+0*sigmar, -4.0D+0*sigmai) c3 = dcmplx( 3.0D+0-sigmar, -sigmai) c do 10 j = 1, n-1 cdl(j) = c1 cdd(j) = c2 cdu(j) = c3 10 continue cdd(n) = c2 c call zgttrf(n, cdl, cdd, cdu, cdu2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV6.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in DNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shift with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of DNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details, see the | c | documentation in DNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------% c | M A I N L O O P(Reverse communication) | c %------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine DNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dnaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, info ) c if (ido .eq. -1) then c c %------------------------------------------------------------% c | Perform | c | y <--- OP*x = Imaginary_Part{inv[A-(SIGMAR,SIGMAI)*M]*M*x} | c | to force starting vector into the range of OP. The user | c | should supply his/her own matrix vector multiplication | c | routine and a complex linear system solver. The matrix | c | vector multiplication routine should take workd(ipntr(1)) | c | as the input. The final result (a real vector) should be | c | returned to workd(ipntr(2)). | c %------------------------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) do 30 j = 1, n ctemp(j) = dcmplx(workd(ipntr(2)+j-1)) 30 continue c call zgttrs('N', n, 1, cdl, cdd, cdu, cdu2, ipiv, & ctemp, maxn, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV6.' print*, ' ' go to 9000 end if do 40 j = 1, n workd(ipntr(2)+j-1) = dimag(ctemp(j)) 40 continue c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 1) then c c %------------------------------------------------------------% c | Perform | c | y <--- OP*x = Imaginary_Part{inv[A-(SIGMAR,SIGMAI)*M]*M*x} | c | M*x has been saved in workd(ipntr(3)). The user only need | c | the complex linear system solver here that takes | c | complex[workd(ipntr(3))] as input, and returns the result | c | to workd(ipntr(2)). | c %------------------------------------------------------------% c do 50 j = 1,n ctemp(j) = dcmplx(workd(ipntr(3)+j-1)) 50 continue call zgttrs ('N', n, 1, cdl, cdd, cdu, cdu2, ipiv, & ctemp, maxn, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV6.' print*, ' ' go to 9000 end if do 60 j = 1, n workd(ipntr(2)+j-1) = dimag(ctemp(j)) 60 continue c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- M*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ',info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. call dneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 70 j=1, nconv c c %-------------------------------------% c | Use Rayleigh Quotient to recover | c | eigenvalues of the original problem.| c %-------------------------------------% c if ( d(j,2) .eq. zero) then c c %----------------------------% c | Eigenvalue is real. | c | Compute d = x'(Ax)/x'(Mx). | c %----------------------------% c call av(n, v(1,j), ax ) numr = ddot(n, v(1,j), 1, ax, 1) call mv(n, v(1,j), ax ) denr = ddot(n, v(1,j), 1, ax, 1) d(j,1) = numr / denr c else if (first) then c c %------------------------% c | Eigenvalue is complex. | c | Compute the first one | c | of the conjugate pair. | c %------------------------% c c %----------------% c | Compute x'(Ax) | c %----------------% c call av(n, v(1,j), ax ) numr = ddot(n, v(1,j), 1, ax, 1) numi = ddot(n, v(1,j+1), 1, ax, 1) call av(n, v(1,j+1), ax) numr = numr + ddot(n,v(1,j+1),1,ax,1) numi = -numi + ddot(n,v(1,j),1,ax,1) c c %----------------% c | Compute x'(Mx) | c %----------------% c call mv(n, v(1,j), ax ) denr = ddot(n, v(1,j), 1, ax, 1) deni = ddot(n, v(1,j+1), 1, ax, 1) call mv(n, v(1,j+1), ax) denr = denr + ddot(n,v(1,j+1),1,ax,1) deni = -deni + ddot(n,v(1,j),1, ax,1) c c %----------------% c | d=x'(Ax)/x'(Mx)| c %----------------% c d(j,1) = (numr*denr+numi*deni) / & dlapy2(denr, deni) d(j,2) = (numi*denr-numr*deni) / & dlapy2(denr, deni) first = .false. c else c c %------------------------------% c | Get the second eigenvalue of | c | the conjugate pair by taking | c | the conjugate of the last | c | eigenvalue computed. | c %------------------------------% c d(j,1) = d(j-1,1) d(j,2) = -d(j-1,2) first = .true. c end if c 70 continue c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c first = .true. nconv = iparam(5) do 80 j=1, nconv c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j+1), mx) call daxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = dnrm2(n, ax, 1) call av(n, v(1,j+1), ax) call mv(n, v(1,j+1), mx) call daxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j), mx) call daxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = dlapy2( d(j,3), dnrm2(n, ax, 1) ) d(j,3) = d(j,3) / dlapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 80 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV6 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dndrv6. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine mv (n, v, w) integer n, j Double precision & v(n), w(n), one, four parameter (one = 1.0D+0, four = 4.0D+0) c c Compute the matrix vector multiplication y<---M*x c where M is a n by n symmetric tridiagonal matrix with 4 on the c diagonal, 1 on the subdiagonal and superdiagonal. c w(1) = four*v(1) + one*v(2) do 10 j = 2,n-1 w(j) = one*v(j-1) + four*v(j) + one*v(j+1) 10 continue w(n) = one*v(n-1) + four*v(n) return end c------------------------------------------------------------------ subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), three, two parameter (three = 3.0D+0, two = 2.0D+0) c c Compute the matrix vector multiplication y<---A*x c where M is a n by n symmetric tridiagonal matrix with 2 on the c diagonal, -2 on the subdiagonal and 3 on the superdiagonal. c w(1) = two*v(1) + three*v(2) do 10 j = 2,n-1 w(j) = -two*v(j-1) + two*v(j) + three*v(j+1) 10 continue w(n) = -two*v(n-1) + two*v(n) return end arpack-akloeckner-07/EXAMPLES/NONSYM/sndrv1.f0000644000175000017500000004025107172775511020336 0ustar andreasandreas program sndrv1 c c c Example program to illustrate the idea of reverse communication c for a standard nonsymmetric eigenvalue problem. c c We implement example one of ex-nonsym.doc in DOCUMENTS directory c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is obtained from the standard central difference c discretization of the convection-diffusion operator c (Laplacian u) + rho*(du / dx) c on the unit square [0,1]x[0,1] with zero Dirichlet boundary c condition. c c ... OP = A and B = I. c c ... Assume "call av (nx,x,y)" computes y = A*x.c c c ... Use mode 1 of SNAUPD. c c\BeginLib c c\Routines called: c snaupd ARPACK reverse communication interface routine. c sneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv1.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c--------------------------------------------------------------------------- c c %-----------------------------% c | Define maximum dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=12, maxncv=30, ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Real & ax(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nx, nev, ncv, lworkl, info, j, & ierr, nconv, maxitr, ishfts, mode Real & tol, sigmar, sigmai logical first, rvec c c %------------% c | Parameters | c %------------% c Real & zero parameter (zero = 0.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & slapy2, snrm2 external slapy2, snrm2, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %--------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | convection-diffusion operator on the unit | c | square with zero Dirichlet boundary condition. | c | The number N(=NX*NX) is the dimension of the | c | matrix. A standard eigenvalue problem is | c | solved (BMAT = 'I'). NEV is the number of | c | eigenvalues to be approximated. The user can | c | modify NX, NEV, NCV, WHICH to solve problems of | c | different sizes, and to get different parts of | c | the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN | c | NEV <= MAXNEV | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'SM' c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of SNAUPD is used | c | (IPARAM(7) = 1). All these options can be changed | c | by the user. For details see the documentation in | c | SNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 1 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call snaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform matrix vector multiplication | c | y <--- OP*x | c | The user should supply his/her own | c | matrix vector multiplication routine here | c | that takes workd(ipntr(1)) as the input | c | vector, and return the matrix vector | c | product to workd(ipntr(2)). | c %-------------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call sneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the imaginary part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(nx, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex. | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(nx, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) call saxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call av(nx, v(1,j+1), ax) call saxpy(n, -d(j,2), v(1,j), 1, ax, 1) call saxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 20 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV1 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program sndrv1. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector subroutine c c The matrix used is the 2 dimensional convection-diffusion c operator discretized using central difference. c subroutine av (nx, v, w) integer nx, j, lo Real & v(nx*nx), w(nx*nx), one, h2 parameter (one = 1.0E+0) external saxpy c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c derived from the standard central difference discretization c of the 2 dimensional convection-diffusion operator c (Laplacian u) + rho*(du/dx) on a unit square with zero boundary c condition. c c When rho*h/2 <= 1, the discrete convection-diffusion operator c has real eigenvalues. When rho*h/2 > 1, it has COMPLEX c eigenvalues. c c The subroutine TV is called to compute y<---T*x. c c h2 = one / real((nx+1)*(nx+1)) c call tv(nx,v(1),w(1)) call saxpy(nx, -one/h2, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call saxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) call saxpy(nx, -one/h2, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call saxpy(nx, -one/h2, v(lo-nx+1), 1, w(lo+1), 1) c return end c========================================================================= subroutine tv (nx, x, y) c integer nx, j Real & x(nx), y(nx), h, h2, dd, dl, du c Real & one, zero, rho parameter (one = 1.0E+0, zero = 0.0E+0, & rho = 0.0E+0) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal. c c When rho*h/2 <= 1, the discrete convection-diffusion operator c has real eigenvalues. When rho*h/2 > 1, it has COMPLEX c eigenvalues. c h = one / real(nx+1) h2 = h*h dd = 4.0E+0 / h2 dl = -one / h2 - 5.0E-1*rho / h du = -one / h2 + 5.0E-1*rho / h c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/NONSYM/sndrv2.f0000644000175000017500000003746507172775624020361 0ustar andreasandreas program sndrv2 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a standard nonsymmetric eigenvalue problem. c c We implement example two of ex-nonsym.doc in DOCUMENTS directory c c\Example-2 c ... Suppose we want to solve A*x = lambda*x in shift-invert mode, c where A is derived from the centered difference discretization c of the 1-dimensional convection-diffusion operator c (d^2u / dx^2) + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition. c c ... The shift sigma is a real number. c c ... OP = inv[A-sigma*I] and B = I. c c ... Use mode 3 of SNAUPD. c c\BeginLib c c\Routines called: c snaupd ARPACK reverse communication interface routine. c sneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgttrf LAPACK tridiagonal factorization routine. c sgttrs LAPACK tridiagonal solve routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c scopy Level 1 BLAS that copies one vector to another. c sdot Level 1 BLAS that computes the dot product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv2.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Real & ax(maxn), d(maxncv,3), resid(maxn), & v(ldv, maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv), & dd(maxn), dl(maxn), du(maxn), & du2(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, & ierr, nconv, maxitr, ishfts, mode Real & tol, h, s, & sigmar, sigmai, s1, s2, s3 logical first, rvec c c %------------% c | Parameters | c %------------% c Real & one, zero, two, rho common /convct/ rho parameter (one = 1.0E+0, zero = 0.0E+0, & two = 2.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & sdot, snrm2, slapy2 external sgttrf, sgttrs, sdot, snrm2, slapy2 c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | standard eigenvalue problem is solved (BMAT = | c | 'I'). NEV is the number of eigenvalues (closest | c | to the shift SIGMAR) to be approximated. Since | c | the shift-invert mode is used, WHICH is set to | c | 'LM'. The user can modify NEV, NCV, SIGMAR to | c | solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV2: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'LM' sigmar = 1.0E+0 sigmai = 0.0E+0 c c %----------------------------------------------------% c | Construct C = A - SIGMA*I in real arithmetic, and | c | factor C in real arithmetic using LAPACK | c | subroutine sgttrf. The matrix A is chosen to be | c | the tridiagonal matrix derived from standard | c | central difference of the 1-d convection diffusion | c | operator u" + rho*u' on the interval [0, 1] with | c | zero Dirichlet boundary condition. | c %----------------------------------------------------% c rho = 1.0E+1 h = one / real(n+1) s = rho*h / two c s1 = -one-s s2 = two - sigmar s3 = -one+s c do 10 j = 1, n-1 dl(j) = s1 dd(j) = s2 du(j) = s3 10 continue dd(n) = s2 c call sgttrf(n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV2.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of SNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details see the | c | documentation in SNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine SNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call snaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if ( ido .eq. -1 .or. ido .eq. 1) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*I]*x | c | The user should supply his/her own linear | c | system solver here that takes | c | workd(ipntr(1)) as the input, and returns | c | the result to workd(ipntr(2)). | c %-------------------------------------------% c call scopy( n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) c call sgttrs('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV2.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation in _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call sneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the imaginary part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) call saxpy(n, d(j,2), v(1,j+1), 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call av(n, v(1,j+1), ax) call saxpy(n, -d(j,2), v(1,j), 1, ax, 1) call saxpy(n, -d(j,1), v(1,j+1), 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 30 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV2 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program sndrv2. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------- c c matrix vector multiplication subroutine c subroutine av (n, v, w) integer n, j Real & v(n), w(n), rho, two, one, dd, dl, du, s, h common /convct/ rho parameter (one = 1.0E+0, two = 2.0E+0 ) c c Compute the matrix vector multiplication y<---A*x c where A is a n by n nonsymmetric tridiagonal matrix derived from c the central difference discretization of the 1-dimensional c convection diffusion operator on the interval [0,1] with c zero Dirichlet boundary condition. c c h = one / real(n+1) s = rho *h / two dd = two dl = -one - s du = -one + s c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end arpack-akloeckner-07/EXAMPLES/NONSYM/sndrv3.f0000644000175000017500000004124607172775720020347 0ustar andreasandreas program sndrv3 c c Simple program to illustrate the idea of reverse communication c in inverse mode for a generalized nonsymmetric eigenvalue problem. c c We implement example three of ex-nonsym.doc in DOCUMENTS directory c c\Example-3 c ... Suppose we want to solve A*x = lambda*B*x in inverse mode, c where A and B are derived from the finite element discretization c of the 1-dimensional convection-diffusion operator c (d^2u / dx^2) + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition c using linear elements. c c ... So OP = inv[M]*A and B = M. c c ... Use mode 2 of SNAUPD. c c\BeginLib c c\Routines called: c snaupd ARPACK reverse communication interface routine. c sneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c spttrf LAPACK symmetric positive definite tridiagonal factorization c routine. c spttrs LAPACK symmetric positive definite tridiagonal solve routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv3.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14) logical select(maxncv) Real & ax(maxn), mx(maxn), d(maxncv, 3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv), & md(maxn), me(maxn-1) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Real & tol, sigmar, sigmai, h logical first, rvec c c %------------% c | Parameters | c %------------% c Real & zero, one parameter (zero = 0.0E+0, one = 1.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% Real & snrm2, slapy2 external saxpy, snrm2, spttrf, spttrs, slapy2 c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues to be | c | approximated. The user can modify NEV, NCV, WHICH | c | to solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' c c %------------------------------------------------% c | M is the mass matrix formed by using piecewise | c | linear elements on [0,1]. | c %------------------------------------------------% c h = one / real(n+1) do 20 j = 1, n-1 md(j) = 4.0E+0*h me(j) = one*h 20 continue md(n) = 4.0E+0*h c call spttrf(n, md, me, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _pttrf. ' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = 0.0 ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of SNAUPD is used | c | (IPARAM(7) = 2). All these options can be | c | changed by the user. For details, see the | c | documentation in SNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 2 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call snaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %----------------------------------------% c | Perform y <--- OP*x = inv[M]*A*x | c | The user should supply his/her own | c | matrix vector routine and a linear | c | system solver. The matrix-vector | c | subroutine should take workd(ipntr(1)) | c | as input, and the final result should | c | be returned to workd(ipntr(2)). | c %----------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call spttrs(n, 1, md, me, workd(ipntr(2)), n, & ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _pttrs. ' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 10 c else if ( ido .eq. 2) then c c %-------------------------------------% c | Perform y <--- M*x | c | The matrix vector multiplication | c | routine should take workd(ipntr(1)) | c | as input and return the result to | c | workd(ipntr(2)). | c %-------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 10 c end if c c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in SNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. call sneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd' print *, ' ' c else c first = .true. nconv = iparam(5) do 30 j=1, iparam(5) c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*M*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j+1), mx) call saxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1)**2 call av(n, v(1,j+1), ax) call mv(n, v(1,j+1), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j), mx) call saxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 30 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV3 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program sndrv3. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine av (n, v, w) integer n, j Real & v(n), w(n), one, two, dd, dl, du, s, h, rho parameter ( rho = 1.0E+1, one = 1.0E+0, & two = 2.0E+0) c c Compute the matrix vector multiplication y<---A*x c where A is stiffness matrix obtained from the finite element c discretization of the 1-dimensional convection diffusion operator c d^2u/dx^2 + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition using c linear elements. c h = one / real(n+1) s = rho / two dd = two / h dl = -one/h - s du = -one/h + s c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end c------------------------------------------------------------------------ subroutine mv (n, v, w) integer n, j Real & v(n), w(n), one, four, h parameter ( one = 1.0E+0, four = 4.0E+0) c c Compute the matrix vector multiplication y<---M*x c where M is the mass matrix formed by using piecewise linear c elements on [0,1]. c w(1) = four*v(1) + one*v(2) do 10 j = 2,n-1 w(j) = one*v(j-1) + four*v(j) + one*v(j+1) 10 continue w(n) = one*v(n-1) + four*v(n) c h = one / real(n+1) call sscal(n, h, w, 1) return end arpack-akloeckner-07/EXAMPLES/NONSYM/sndrv4.f0000644000175000017500000004633007172772330020341 0ustar andreasandreas program sndrv4 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a generalized nonsymmetric eigenvalue c problem. c c We implement example four of ex-nonsym.doc in DOCUMENTS directory c c\Example-4 c ... Suppose we want to solve A*x = lambda*B*x in inverse mode, c where A and B are derived from the finite element discretization c of the 1-dimensional convection-diffusion operator c (d^2u / dx^2) + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition c using linear elements. c c ... The shift sigma is a real number. c c ... OP = inv[A-SIGMA*M]*M and B = M. c c ... Use mode 3 of SNAUPD. c c\BeginLib c c\Routines called: c snaupd ARPACK reverse communication interface routine. c sneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgttrf LAPACK tridiagonal factorization routine. c sgttrs LAPACK tridiagonal linear system solve routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c scopy Level 1 BLAS that copies one vector to another. c sdot Level 1 BLAS that computes the dot product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv4.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c----------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Real & ax(maxn), mx(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv), & dd(maxn), dl(maxn), du(maxn), & du2(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Real & tol, h, s, & sigmar, sigmai, s1, s2, s3 logical first, rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & sdot, snrm2, slapy2 external sdot, snrm2, slapy2, sgttrf, sgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %------------% c | Parameters | c %------------% c Real & one, zero, two, six, rho common /convct/ rho parameter (one = 1.0E+0, zero = 0.0E+0, & two = 2.0E+0, six = 6.0E+0) c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues (closest | c | to SIGMAR) to be approximated. Since the | c | shift-invert mode is used, WHICH is set to 'LM'. | c | The user can modify NEV, NCV, SIGMAR to solve | c | problems of different sizes, and to get different | c | parts of the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = one sigmai = zero c c %--------------------------------------------------% c | Construct C = A - SIGMA*M in real arithmetic, | c | and factor C in real arithmetic (using LAPACK | c | subroutine sgttrf). The matrix A is chosen to be | c | the tridiagonal matrix derived from the standard | c | central difference discretization of the 1-d | c | convection-diffusion operator u" + rho*u' on the | c | interval [0, 1] with zero Dirichlet boundary | c | condition. The matrix M is the mass matrix | c | formed by using piecewise linear elements on | c | [0,1]. | c %--------------------------------------------------% c rho = 1.0E+1 h = one / real(n+1) s = rho / two c s1 = -one/h - s - sigmar*h/six s2 = two/h - 4.0E+0*sigmar*h/six s3 = -one/h + s - sigmar*h/six c do 10 j = 1, n-1 dl(j) = s1 dd(j) = s2 du(j) = s3 10 continue dd(n) = s2 c call sgttrf(n, dl, dd, du, du2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of SNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details, see the | c | documentation in SNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------% c | M A I N L O O P(Reverse communication) | c %------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine SNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call snaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, info ) c if (ido .eq. -1) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*M]*M*x | c | to force starting vector into the range | c | of OP. The user should supply his/her | c | own matrix vector multiplication routine | c | and a linear system solver. The matrix | c | vector multiplication routine should take | c | workd(ipntr(1)) as the input. The final | c | result should be returned to | c | workd(ipntr(2)). | c %-------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) call sgttrs('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 1) then c c %-----------------------------------------% c | Perform y <-- OP*x = inv[A-sigma*M]*M*x | c | M*x has been saved in workd(ipntr(3)). | c | The user only need the linear system | c | solver here that takes workd(ipntr(3)) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call scopy( n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call sgttrs ('N', n, 1, dl, dd, du, du2, ipiv, & workd(ipntr(2)), n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV4.' print*, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- M*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ', info print *, ' Check the documentation in _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. call sneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex. | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j+1), mx) call saxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call av(n, v(1,j+1), ax) call mv(n, v(1,j+1), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j), mx) call saxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 30 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV4 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program sndrv4. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine mv (n, v, w) integer n, j Real & v(n), w(n), one, four, six, h parameter (one = 1.0E+0, four = 4.0E+0, six = 6.0E+0) c c Compute the matrix vector multiplication y<---M*x c where M is mass matrix formed by using piecewise linear elements c on [0,1]. c w(1) = ( four*v(1) + one*v(2) ) / six do 10 j = 2,n-1 w(j) = ( one*v(j-1) + four*v(j) + one*v(j+1) ) / six 10 continue w(n) = ( one*v(n-1) + four*v(n) ) / six c h = one / real(n+1) call sscal(n, h, w, 1) return end c------------------------------------------------------------------ subroutine av (n, v, w) integer n, j Real & v(n), w(n), one, two, dd, dl, du, s, h, rho common /convct/ rho parameter (one = 1.0E+0, two = 2.0E+0) c c Compute the matrix vector multiplication y<---A*x c where A is obtained from the finite element discretization of the c 1-dimensional convection diffusion operator c d^u/dx^2 + rho*(du/dx) c on the interval [0,1] with zero Dirichlet boundary condition c using linear elements. c This routine is only used in residual calculation. c h = one / real(n+1) s = rho / two dd = two / h dl = -one/h - s du = -one/h + s c w(1) = dd*v(1) + du*v(2) do 10 j = 2,n-1 w(j) = dl*v(j-1) + dd*v(j) + du*v(j+1) 10 continue w(n) = dl*v(n-1) + dd*v(n) return end arpack-akloeckner-07/EXAMPLES/NONSYM/sndrv5.f0000644000175000017500000005316107172776123020346 0ustar andreasandreas program sndrv5 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a generalized nonsymmetric eigenvalue problem. c c We implement example five of ex-nonsym.doc in DOCUMENTS directory c c\Example-5 c c ... Suppose we want to solve A*x = lambda*B*x in shift-invert mode c The matrix A is the tridiagonal matrix with 2 on the diagonal, c -2 on the subdiagonal and 3 on the superdiagonal. The matrix M c is the tridiagonal matrix with 4 on the diagonal and 1 on the c off-diagonals. c ... The shift sigma is a complex number (sigmar, sigmai). c ... OP = Real_Part{inv[A-(SIGMAR,SIGMAI)*M]*M and B = M. c ... Use mode 3 of SNAUPD. c c\BeginLib c c\Routines called: c snaupd ARPACK reverse communication interface routine. c sneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c cgttrf LAPACK complex matrix factorization routine. c cgttrs LAPACK complex linear system solve routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c sdot Level 1 BLAS that computes the dot product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector c av Matrix vector subroutine that computes A*x. c mv Matrix vector subroutine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv5.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Real & ax(maxn), mx(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv) Complex & cdd(maxn), cdl(maxn), cdu(maxn), & cdu2(maxn), ctemp(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Real & tol, numr, numi, denr, deni, sigmar, sigmai Complex & c1, c2, c3 logical first, rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c external cgttrf, cgttrs Real & sdot, snrm2, slapy2 external sdot, snrm2, slapy2 c c c %------------% c | Parameters | c %------------% c Real & zero parameter (zero = 0.0E+0) c c %--------------------% c | Intrinsic Function | c %--------------------% c intrinsic real, cmplx, abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues (closest | c | to the shift (SIGMAR,SIGMAI)) to be approximated. | c | Since the shift-invert mode is used, WHICH is set | c | to 'LM'. The user can modify NEV, NCV, SIGMAR, | c | SIGMAI to solve problems of different sizes, and | c | to get different parts of the spectrum. However, | c | The following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV5: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV5: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV5: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = 4.0E-1 sigmai = 6.0E-1 c c %---------------------------------------------------% c | Construct C = A - (SIGMAR,SIGMAI)*M in complex | c | arithmetic, and factor C in complex arithmetic | c | (using LAPACK subroutine cgttrf). The matrix A is | c | chosen to be the tridiagonal matrix with -2 on | c | the subdiagonal, 2 on the diagonal and 3 on the | c | superdiagonal. The matrix M is chosen to the | c | symmetric tridiagonal matrix with 4 on the | c | diagonal and 1 on the off-diagonals. | c %---------------------------------------------------% c c1 = cmplx(-2.0E+0-sigmar, -sigmai) c2 = cmplx( 2.0E+0-4.0E+0*sigmar, -4.0E+0*sigmai) c3 = cmplx( 3.0E+0-sigmar, -sigmai) c do 10 j = 1, n-1 cdl(j) = c1 cdd(j) = c2 cdu(j) = c3 10 continue cdd(n) = c2 c call cgttrf(n, cdl, cdd, cdu, cdu2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV5.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shift with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of SNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details, see the | c | documentation in SNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------% c | M A I N L O O P(Reverse communication) | c %------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine SNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call snaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, info ) c if (ido .eq. -1) then c c %-------------------------------------------------------% c | Perform | c | y <--- OP*x = Real_Part{inv[A-(SIGMAR,SIGMAI)*M]*M*x} | c | to force starting vector into the range of OP. The | c | user should supply his/her own matrix vector | c | multiplication routine and a complex linear system | c | solver. The matrix vector multiplication routine | c | should take workd(ipntr(1)) as the input. The final | c | result (a real vector) should be returned to | c | workd(ipntr(2)). | c %-------------------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) do 30 j = 1, n ctemp(j) = cmplx(workd(ipntr(2)+j-1)) 30 continue c call cgttrs('N', n, 1, cdl, cdd, cdu, cdu2, ipiv, & ctemp, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV5.' print*, ' ' go to 9000 end if do 40 j = 1, n workd(ipntr(2)+j-1) = real(ctemp(j)) 40 continue c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 1) then c c %-------------------------------------------------------% c | Perform | c | y <--- OP*x = Real_Part{inv[A-(SIGMAR,SIGMAI)*M]*M*x} | c | M*x has been saved in workd(ipntr(3)). The user only | c | needs the complex linear system solver here that | c | takes complex[workd(ipntr(3))] as input, and returns | c | the result to workd(ipntr(2)). | c %-------------------------------------------------------% c do 50 j = 1,n ctemp(j) = cmplx(workd(ipntr(3)+j-1)) 50 continue call cgttrs ('N', n, 1, cdl, cdd, cdu, cdu2, ipiv, & ctemp, n, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV5.' print*, ' ' go to 9000 end if do 60 j = 1, n workd(ipntr(2)+j-1) = real(ctemp(j)) 60 continue c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- M*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c c %------------------------------------------% c | Either we have convergence, or there is | c | an error. | c %------------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd info = ',info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. call sneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 70 j=1,nconv c c %-------------------------------------% c | Use Rayleigh Quotient to recover | c | eigenvalues of the original problem.| c %-------------------------------------% c if ( d(j,2) .eq. zero ) then c c %---------------------------% c | Eigenvalue is real. | c | Compute d = x'(Ax)/x'(Mx).| c %---------------------------% c call av(n, v(1,j), ax ) numr = sdot(n, v(1,j), 1, ax, 1) call mv(n, v(1,j), ax ) denr = sdot(n, v(1,j), 1, ax, 1) d(j,1) = numr / denr c else if (first) then c c %------------------------% c | Eigenvalue is complex. | c | Compute the first one | c | of the conjugate pair. | c %------------------------% c c %----------------% c | Compute x'(Ax) | c %----------------% call av(n, v(1,j), ax ) numr = sdot(n, v(1,j), 1, ax, 1) numi = sdot(n, v(1,j+1), 1, ax, 1) call av(n, v(1,j+1), ax) numr = numr + sdot(n,v(1,j+1),1,ax,1) numi = -numi + sdot(n,v(1,j),1,ax,1) c c %----------------% c | Compute x'(Mx) | c %----------------% c call mv(n, v(1,j), ax ) denr = sdot(n, v(1,j), 1, ax, 1) deni = sdot(n, v(1,j+1), 1, ax, 1) call mv(n, v(1,j+1), ax) denr = denr + sdot(n,v(1,j+1),1,ax,1) deni = -deni + sdot(n,v(1,j),1, ax,1) c c %----------------% c | d=x'(Ax)/x'(Mx)| c %----------------% c d(j,1) = (numr*denr+numi*deni) / & slapy2(denr, deni) d(j,2) = (numi*denr-numr*deni) / & slapy2(denr, deni) first = .false. c else c c %------------------------------% c | Get the second eigenvalue of | c | the conjugate pair by taking | c | the conjugate of the last | c | eigenvalue computed. | c %------------------------------% c d(j,1) = d(j-1,1) d(j,2) = -d(j-1,2) first = .true. c end if c 70 continue c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c first = .true. do 80 j=1, nconv c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j+1), mx) call saxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call av(n, v(1,j+1), ax) call mv(n, v(1,j+1), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j), mx) call saxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 80 continue c c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV5 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program sndrv5. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine mv (n, v, w) integer n, j Real & v(n), w(n), one, four parameter (one = 1.0E+0, four = 4.0E+0) c c Compute the matrix vector multiplication y<---M*x c where M is a n by n symmetric tridiagonal matrix with 4 on the c diagonal, 1 on the subdiagonal and superdiagonal. c w(1) = four*v(1) + one*v(2) do 10 j = 2,n-1 w(j) = one*v(j-1) + four*v(j) + one*v(j+1) 10 continue w(n) = one*v(n-1) + four*v(n) return end c------------------------------------------------------------------ subroutine av (n, v, w) integer n, j Real & v(n), w(n), three, two parameter (three = 3.0E+0, two = 2.0E+0) c c Compute the matrix vector multiplication y<---A*x c where M is a n by n symmetric tridiagonal matrix with 2 on the c diagonal, -2 on the subdiagonal and 3 on the superdiagonal. c w(1) = two*v(1) + three*v(2) do 10 j = 2,n-1 w(j) = -two*v(j-1) + two*v(j) + three*v(j+1) 10 continue w(n) = -two*v(n-1) + two*v(n) return end arpack-akloeckner-07/EXAMPLES/NONSYM/sndrv6.f0000644000175000017500000005335507172776274020363 0ustar andreasandreas program sndrv6 c c Simple program to illustrate the idea of reverse communication c in shift-invert mode for a generalized nonsymmetric eigenvalue problem. c c We implement example six of ex-nonsym.doc in DOCUMENTS directory c c\Example-6 c c ... Suppose we want to solve A*x = lambda*B*x in shift-invert mode c The matrix A is the tridiagonal matrix with 2 on the diagonal, c -2 on the subdiagonal and 3 on the superdiagonal. The matrix M c is the tridiagonal matrix with 4 on the diagonal and 1 on the c off-diagonals. c ... The shift sigma is a complex number (sigmar, sigmai). c ... OP = Imaginary_Part{inv[A-(SIGMAR,SIGMAI)*M]*M and B = M. c ... Use mode 4 of SNAUPD. c c\BeginLib c c\Routines called: c snaupd ARPACK reverse communication interface routine. c sneupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c cgttrf LAPACK complex matrix factorization routine. c cgttrs LAPACK complex linear system solve routine. c slapy2 LAPACK routine to compute sqrt(x**2+y**2) carefully. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c sdot Level 1 BLAS that computes the dot product of two vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector subroutine that computes A*x. c mv Matrix vector subroutine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: ndrv6.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c integer iparam(11), ipntr(14), ipiv(maxn) logical select(maxncv) Real & ax(maxn), mx(maxn), d(maxncv,3), resid(maxn), & v(ldv,maxncv), workd(3*maxn), & workev(3*maxncv), & workl(3*maxncv*maxncv+6*maxncv) Complex & cdd(maxn), cdl(maxn), cdu(maxn), & cdu2(maxn), ctemp(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nconv, maxitr, ishfts, mode Real & tol, numr, numi, denr, deni, sigmar, sigmai Complex & c1, c2, c3 logical first, rvec c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c external cgttrf, cgttrs Real & sdot, snrm2, slapy2 external sdot, snrm2, slapy2 c c %------------% c | Parameters | c %------------% c Real & zero parameter (zero = 0.0E+0) c c %--------------------% c | Intrinsic Function | c %--------------------% c intrinsic aimag, cmplx, abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'). NEV is the number of eigenvalues (closest | c | to the shift (SIGMAR,SIGMAI)) to be approximated. | c | Since the shift-invert mode is used, WHICH is set | c | to 'LM'. The user can modify NEV, NCV, SIGMA to | c | solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 2 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _NDRV6: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _NDRV6: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _NDRV6: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigmar = 4.0E-1 sigmai = 6.0E-1 c c %----------------------------------------------------% c | Construct C = A - (SIGMAR,SIGMAI)*M in complex | c | arithmetic, and factor C in complex arithmetic | c | (using LAPACK subroutine cgttrf). The matrix A is | c | chosen to be the tridiagonal matrix with -2 on the | c | subdiagonal, 2 on the diagonal and 3 on the | c | superdiagonal. The matrix M is chosen to be the | c | symmetric tridiagonal matrix with 4 on the | c | diagonal and 1 on the off-diagonals. | c %----------------------------------------------------% c c1 = cmplx(-2.0E+0-sigmar, -sigmai) c2 = cmplx( 2.0E+0-4.0E+0*sigmar, -4.0E+0*sigmai) c3 = cmplx( 3.0E+0-sigmar, -sigmai) c do 10 j = 1, n-1 cdl(j) = c1 cdd(j) = c2 cdu(j) = c3 10 continue cdd(n) = c2 c call cgttrf(n, cdl, cdd, cdu, cdu2, ipiv, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrf in _NDRV6.' print*, ' ' go to 9000 end if c c %-----------------------------------------------------% c | The work array WORKL is used in SNAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SNAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = 3*ncv**2+6*ncv tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shift with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of SNAUPD is used | c | (IPARAM(7) = 3). All these options can be | c | changed by the user. For details, see the | c | documentation in SNAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------% c | M A I N L O O P(Reverse communication) | c %------------------------------------------% c 20 continue c c %---------------------------------------------% c | Repeatedly call the routine SNAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call snaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, info ) c if (ido .eq. -1) then c c %------------------------------------------------------------% c | Perform | c | y <--- OP*x = Imaginary_Part{inv[A-(SIGMAR,SIGMAI)*M]*M*x} | c | to force starting vector into the range of OP. The user | c | should supply his/her own matrix vector multiplication | c | routine and a complex linear system solver. The matrix | c | vector multiplication routine should take workd(ipntr(1)) | c | as the input. The final result (a real vector) should be | c | returned to workd(ipntr(2)). | c %------------------------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) do 30 j = 1, n ctemp(j) = cmplx(workd(ipntr(2)+j-1)) 30 continue c call cgttrs('N', n, 1, cdl, cdd, cdu, cdu2, ipiv, & ctemp, maxn, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV6.' print*, ' ' go to 9000 end if do 40 j = 1, n workd(ipntr(2)+j-1) = aimag(ctemp(j)) 40 continue c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 1) then c c %------------------------------------------------------------% c | Perform | c | y <--- OP*x = Imaginary_Part{inv[A-(SIGMAR,SIGMAI)*M]*M*x} | c | M*x has been saved in workd(ipntr(3)). The user only need | c | the complex linear system solver here that takes | c | complex[workd(ipntr(3))] as input, and returns the result | c | to workd(ipntr(2)). | c %------------------------------------------------------------% c do 50 j = 1,n ctemp(j) = cmplx(workd(ipntr(3)+j-1)) 50 continue call cgttrs ('N', n, 1, cdl, cdd, cdu, cdu2, ipiv, & ctemp, maxn, ierr) if ( ierr .ne. 0 ) then print*, ' ' print*, ' ERROR with _gttrs in _NDRV6.' print*, ' ' go to 9000 end if do 60 j = 1, n workd(ipntr(2)+j-1) = aimag(ctemp(j)) 60 continue c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c else if ( ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- M*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SNAUPD again. | c %-----------------------------------------% c go to 20 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SNAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _naupd, info = ',info print *, ' Check the documentation of _naupd.' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SNEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. call sneupd ( rvec, 'A', select, d, d(1,2), v, ldv, & sigmar, sigmai, workev, bmat, n, which, nev, tol, & resid, ncv, v, ldv, iparam, ipntr, workd, & workl, lworkl, ierr ) c c %-----------------------------------------------% c | The real part of the eigenvalue is returned | c | in the first column of the two dimensional | c | array D, and the IMAGINARY part is returned | c | in the second column of D. The corresponding | c | eigenvectors are returned in the first NEV | c | columns of the two dimensional array V if | c | requested. Otherwise, an orthogonal basis | c | for the invariant subspace corresponding to | c | the eigenvalues in D is returned in V. | c %-----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SNEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _neupd, info = ', ierr print *, ' Check the documentation of _neupd. ' print *, ' ' c else c first = .true. nconv = iparam(5) do 70 j=1, nconv c c %-------------------------------------% c | Use Rayleigh Quotient to recover | c | eigenvalues of the original problem.| c %-------------------------------------% c if ( d(j,2) .eq. zero) then c c %----------------------------% c | Eigenvalue is real. | c | Compute d = x'(Ax)/x'(Mx). | c %----------------------------% c call av(n, v(1,j), ax ) numr = sdot(n, v(1,j), 1, ax, 1) call mv(n, v(1,j), ax ) denr = sdot(n, v(1,j), 1, ax, 1) d(j,1) = numr / denr c else if (first) then c c %------------------------% c | Eigenvalue is complex. | c | Compute the first one | c | of the conjugate pair. | c %------------------------% c c %----------------% c | Compute x'(Ax) | c %----------------% c call av(n, v(1,j), ax ) numr = sdot(n, v(1,j), 1, ax, 1) numi = sdot(n, v(1,j+1), 1, ax, 1) call av(n, v(1,j+1), ax) numr = numr + sdot(n,v(1,j+1),1,ax,1) numi = -numi + sdot(n,v(1,j),1,ax,1) c c %----------------% c | Compute x'(Mx) | c %----------------% c call mv(n, v(1,j), ax ) denr = sdot(n, v(1,j), 1, ax, 1) deni = sdot(n, v(1,j+1), 1, ax, 1) call mv(n, v(1,j+1), ax) denr = denr + sdot(n,v(1,j+1),1,ax,1) deni = -deni + sdot(n,v(1,j),1, ax,1) c c %----------------% c | d=x'(Ax)/x'(Mx)| c %----------------% c d(j,1) = (numr*denr+numi*deni) / & slapy2(denr, deni) d(j,2) = (numi*denr-numr*deni) / & slapy2(denr, deni) first = .false. c else c c %------------------------------% c | Get the second eigenvalue of | c | the conjugate pair by taking | c | the conjugate of the last | c | eigenvalue computed. | c %------------------------------% c d(j,1) = d(j-1,1) d(j,2) = -d(j-1,2) first = .true. c end if c 70 continue c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c first = .true. nconv = iparam(5) do 80 j=1, nconv c if (d(j,2) .eq. zero) then c c %--------------------% c | Ritz value is real | c %--------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) d(j,3) = d(j,3) / abs(d(j,1)) c else if (first) then c c %------------------------% c | Ritz value is complex | c | Residual of one Ritz | c | value of the conjugate | c | pair is computed. | c %------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j+1), mx) call saxpy(n, d(j,2), mx, 1, ax, 1) d(j,3) = snrm2(n, ax, 1) call av(n, v(1,j+1), ax) call mv(n, v(1,j+1), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) call mv(n, v(1,j), mx) call saxpy(n, -d(j,2), mx, 1, ax, 1) d(j,3) = slapy2( d(j,3), snrm2(n, ax, 1) ) d(j,3) = d(j,3) / slapy2(d(j,1),d(j,2)) d(j+1,3) = d(j,3) first = .false. else first = .true. end if c 80 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 3, d, maxncv, -6, & 'Ritz values (Real,Imag) and relative residuals') c end if c c %-------------------------------------------% c | Print additional convergence information. | c %-------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _NDRV6 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program sndrv6. | c %---------------------------% c 9000 continue c end c c========================================================================== c c matrix vector multiplication subroutine c subroutine mv (n, v, w) integer n, j Real & v(n), w(n), one, four parameter (one = 1.0E+0, four = 4.0E+0) c c Compute the matrix vector multiplication y<---M*x c where M is a n by n symmetric tridiagonal matrix with 4 on the c diagonal, 1 on the subdiagonal and superdiagonal. c w(1) = four*v(1) + one*v(2) do 10 j = 2,n-1 w(j) = one*v(j-1) + four*v(j) + one*v(j+1) 10 continue w(n) = one*v(n-1) + four*v(n) return end c------------------------------------------------------------------ subroutine av (n, v, w) integer n, j Real & v(n), w(n), three, two parameter (three = 3.0E+0, two = 2.0E+0) c c Compute the matrix vector multiplication y<---A*x c where M is a n by n symmetric tridiagonal matrix with 2 on the c diagonal, -2 on the subdiagonal and 3 on the superdiagonal. c w(1) = two*v(1) + three*v(2) do 10 j = 2,n-1 w(j) = -two*v(j-1) + two*v(j) + three*v(j+1) 10 continue w(n) = -two*v(n-1) + two*v(n) return end arpack-akloeckner-07/EXAMPLES/NONSYM/makefile0000644000175000017500000000373106221770753020451 0ustar andreasandreas# # makefile to run simple examples of the reverse communication # protocol. # # Modify if ARPACK library was built somewhere else. # # If ALIBS (defined in ../../ARmake.inc) contains the BLAS and LAPACK # libraries installed on your system, you DO NOT need to change this # makefile. OTHERWISE, you may need to modify the Makefile in the top level # ARPACK directory tree to include sdrv and/or ddrv in the # definition of the PRECISION variable, and issue 'make lib' from there. # For example: # # PRECISION = single double sdrv ddrv # #\SCCS Information: @(#) # FILE: makefile SID: 2.2 DATE OF SID: 9/24/96 RELEASE: 2 # include ../../ARmake.inc # # Issue "make nonsym" to make all 12 nonsymmetric drivers. # Issue "make sndrv" to make 6 single precision nonsymmetric drivers. # Issue "make dndrv" to make 6 double precision nonsymmetric drivers. # nonsym: sndrv dndrv # #----------------------------------------------------------------------- # Simple nonsymmetric problem using single precision # sndrv: sndrv1 sndrv2 sndrv3 sndrv4 sndrv5 sndrv6 sndrv1: sndrv1.o $(FC) $(FFLAGS) sndrv1.o $(ALIBS) -o sndrv1 # sndrv2: sndrv2.o $(FC) $(FFLAGS) sndrv2.o $(ALIBS) -o sndrv2 # sndrv3: sndrv3.o $(FC) $(FFLAGS) sndrv3.o $(ALIBS) -o sndrv3 # sndrv4: sndrv4.o $(FC) $(FFLAGS) sndrv4.o $(ALIBS) -o sndrv4 # sndrv5: sndrv5.o $(FC) $(FFLAGS) sndrv5.o $(ALIBS) -o sndrv5 # sndrv6: sndrv6.o $(FC) $(FFLAGS) sndrv6.o $(ALIBS) -o sndrv6 # #------------------------------------------------------ # Simple nonsymmetric problem using double precision # dndrv: dndrv1 dndrv2 dndrv3 dndrv4 dndrv5 dndrv6 dndrv1: dndrv1.o $(FC) $(FFLAGS) dndrv1.o $(ALIBS) -o dndrv1 # dndrv2: dndrv2.o $(FC) $(FFLAGS) dndrv2.o $(ALIBS) -o dndrv2 # dndrv3: dndrv3.o $(FC) $(FFLAGS) dndrv3.o $(ALIBS) -o dndrv3 # dndrv4: dndrv4.o $(FC) $(FFLAGS) dndrv4.o $(ALIBS) -o dndrv4 # dndrv5: dndrv5.o $(FC) $(FFLAGS) dndrv5.o $(ALIBS) -o dndrv5 # dndrv6: dndrv6.o $(FC) $(FFLAGS) dndrv6.o $(ALIBS) -o dndrv6 arpack-akloeckner-07/EXAMPLES/SYM/0000755000175000017500000000000007174102033016356 5ustar andreasandreasarpack-akloeckner-07/EXAMPLES/SYM/dsdrv1.f0000644000175000017500000003420707172774146017760 0ustar andreasandreas program dsdrv1 c c Simple program to illustrate the idea of reverse communication c in regular mode for a standard symmetric eigenvalue problem. c c We implement example one of ex-sym.doc in SRC directory c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is derived from the central difference discretization c of the 2-dimensional Laplacian on the unit square [0,1]x[0,1] c with zero Dirichlet boundary condition. c c ... OP = A and B = I. c c ... Assume "call av (n,x,y)" computes y = A*x. c c ... Use mode 1 of DSAUPD. c c\BeginLib c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dnrm2 Level 1 BLAS that computes the norm of a vector. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv1.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, $ ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Double precision & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ax(maxn) logical select(maxncv) integer iparam(11), ipntr(11) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nx, nconv, maxitr, mode, ishfts logical rvec Double precision & tol, sigma c c %------------% c | Parameters | c %------------% c Double precision & zero parameter (zero = 0.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dnrm2 external dnrm2, daxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | Laplacian on the unit square with zero Dirichlet | c | boundary condition. The number N(=NX*NX) is the | c | dimension of the matrix. A standard eigenvalue | c | problem is solved (BMAT = 'I'). NEV is the number | c | of eigenvalues to be approximated. The user can | c | modify NEV, NCV, WHICH to solve problems of | c | different sizes, and to get different parts of the | c | spectrum. However, The following conditions must | c | be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %----------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'SM' c c %--------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero info = 0 ido = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of DSAUPD is used | c | (IPARAM(7) = 1). All these options may be | c | changed by the user. For details, see the | c | documentation in DSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 1 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dsaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %--------------------------------------% c | Perform matrix vector multiplication | c | y <--- OP*x | c | The user should supply his/her own | c | matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as | c | the input, and return the result to | c | workd(ipntr(2)). | c %--------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in DSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ', info print *, ' Check documentation in _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call dseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(nx, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = dnrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 20 continue c c %-------------------------------% c | Display computed residuals | c %-------------------------------% c call dmout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV1 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dsdrv1. | c %---------------------------% c 9000 continue c end c c ------------------------------------------------------------------ c matrix vector subroutine c c The matrix used is the 2 dimensional discrete Laplacian on unit c square with zero Dirichlet boundary condition. c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c The subroutine TV is called to computed y<---T*x. c subroutine av (nx, v, w) integer nx, j, lo, n2 Double precision & v(nx*nx), w(nx*nx), one, h2 parameter ( one = 1.0D+0 ) c call tv(nx,v(1),w(1)) call daxpy(nx, -one, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call daxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1) call daxpy(nx, -one, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call daxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1) c c Scale the vector w by (1/h^2), where h is the mesh size c n2 = nx*nx h2 = one / dble((nx+1)*(nx+1)) call dscal(n2, one/h2, w, 1) return end c c------------------------------------------------------------------- subroutine tv (nx, x, y) c integer nx, j Double precision & x(nx), y(nx), dd, dl, du c Double precision & one parameter (one = 1.0D+0 ) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal. c c dd = 4.0D+0 dl = -one du = -one c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/SYM/dsdrv2.f0000644000175000017500000003330007172774324017750 0ustar andreasandreas program dsdrv2 c c Program to illustrate the idea of reverse communication c in shift and invert mode for a standard symmetric eigenvalue c problem. The following program uses the two LAPACK subroutines c dgttrf.f and dgttrs.f to factor and solve a tridiagonal system of c equations. c c We implement example two of ex-sym.doc in DOCUMENTS directory c c\Example-2 c ... Suppose we want to solve A*x = lambda*x in shift-invert mode, c where A is derived from the central difference discretization c of the 1-dimensional Laplacian on [0,1] with zero Dirichlet c boundary condition. c ... OP = (inv[A - sigma*I]) and B = I. c ... Use mode 3 of DSAUPD. c c\BeginLib c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgttrf LAPACK tridiagonal factorization routine. c dgttrs LAPACK tridiagonal solve routine. c daxpy daxpy Level 1 BLAS that computes y <- alpha*x+y. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv2.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c---------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Double precision & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn), & ax(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Double precision & sigma, tol, h2 c c %------------% c | Parameters | c %------------% c Double precision & zero, one, two parameter (zero = 0.0D+0, one = 1.0D+0, & two = 2.0D+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dnrm2 external daxpy, dnrm2, dgttrf, dgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | standard eigenvalue problem is solved (BMAT = 'I'. | c | NEV is the number of eigenvalues (closest to | c | SIGMA) to be approximated. Since the shift-invert | c | mode is used, WHICH is set to 'LM'. The user can | c | modify NEV, NCV, SIGMA to solve problems of | c | different sizes, and to get different parts of the | c | spectrum. However, The following conditions must | c | be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV2: NCV is greater than MAXNCV ' go to 9000 end if c bmat = 'I' which = 'LM' sigma = zero c c %--------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of DSAUPD is used | c | (IPARAM(7) = 3). All these options may be | c | changed by the user. For details, see the | c | documentation in DSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-----------------------------------------------------% c | Call LAPACK routine to factor (A-SIGMA*I), where A | c | is the 1-d Laplacian. | c %-----------------------------------------------------% c h2 = one / dble((n+1)*(n+1)) do 20 j=1,n ad(j) = two / h2 - sigma adl(j) = -one / h2 20 continue call dcopy (n, adl, 1, adu, 1) call dgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrf in SDRV2.' print *, ' ' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dsaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %----------------------------------------% c | Perform y <-- OP*x = inv[A-sigma*I]*x. | c | The user only need the linear system | c | solver here that takes workd(ipntr(1)) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %----------------------------------------% c call dcopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) c call dgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV2. ' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %----------------------------% c | Error message. Check the | c | documentation in DSAUPD | c %----------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check documentation of _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call dseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd ' print *, ' ' c else c nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call daxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = dnrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 30 continue c c %-------------------------------% c | Display computed residuals | c %-------------------------------% c call dmout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV2 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dsdrv2. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the 1 dimensional discrete Laplacian on c the interval [0,1] with zero Dirichlet boundary condition. c subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), one, two, h2 parameter (one = 1.0D+0, two = 2.0D+0) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1 / h^2). c h2 = one / dble((n+1)*(n+1)) call dscal(n, one/h2, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/dsdrv3.f0000644000175000017500000003752707174102005017747 0ustar andreasandreas program dsdrv3 c c Program to illustrate the idea of reverse communication in c inverse mode for a generalized symmetric eigenvalue problem. c The following program uses the two LAPACK subroutines dgttrf .f c and dgttrs .f to factor and solve a tridiagonal system of equations. c c We implement example three of ex-sym.doc in DOCUMENTS directory c c\Example-3 c ... Suppose we want to solve A*x = lambda*M*x in inverse mode, c where A and M are obtained by the finite element of the c 1-dimensional discrete Laplacian c d^2u / dx^2 c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c c ... OP = inv[M]*A and B = M. c c ... Use mode 2 of DSAUPD . c c\BeginLib c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgttrf LAPACK tridiagonal factorization routine. c dgttrs LAPACK tridiagonal solve routine. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dscal Level 1 BLAS that scales a vector by a scalar. c dcopy Level 1 BLAS that copies one vector to another. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv3.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Double precision & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn), & ax(maxn), mx(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Double precision & sigma, r1, r2, tol, h c c %------------% c | Parameters | c %------------% c Double precision & zero, one, four, six parameter ( zero = 0.0D+0 , one = 1.0D+0 , & four = 4.0D+0 , six = 6.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dnrm2 external daxpy , dcopy , dscal , dnrm2 , dgttrf , dgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'.) NEV is the number of eigenvalues to be | c | approximated. The user can modify NEV, NCV, WHICH | c | to solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' c c %--------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of DSAUPD is used | c | (IPARAM(7) = 2). All these options may be | c | changed by the user. For details, see the | c | documentation in DSAUPD . | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 2 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------------% c | Call LAPACK routine to factor the mass matrix. | c | The mass matrix is the tridiagonal matrix | c | arising from using piecewise linear finite | c | elements on the interval [0, 1]. | c %------------------------------------------------% c h = one / dble (n+1) c r1 = (four / six) * h r2 = (one / six) * h do 20 j=1,n ad(j) = r1 adl(j) = r2 20 continue call dcopy (n, adl, 1, adu, 1) call dgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrf in _SDRV3. ' print *, ' ' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dsaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %--------------------------------------% c | Perform y <--- OP*x = inv[M]*A*x. | c | The user should supply his/her own | c | matrix vector multiplication (A*x) | c | routine and a linear system solver | c | here. The matrix vector | c | multiplication routine takes | c | workd(ipntr(1)) as the input vector. | c | The final result is returned to | c | workd(ipntr(2)). The result of A*x | c | overwrites workd(ipntr(1)). | c %--------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call dcopy (n, workd(ipntr(2)), 1, workd(ipntr(1)), 1) call dgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV3.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 2) then c c %-----------------------------------------% c | Perform y <--- M*x. | c | Need the matrix vector multiplication | c | routine here that takes workd(ipntr(1)) | c | as the input and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DSAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check the documentation of _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DSEUPD . | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call dseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if (ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DSEUPD . | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd' print *, ' ' c else c nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*M*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = dnrm2 (n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 30 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call dmout (6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV3 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dsdrv3 . | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the 1 dimensional mass matrix c on the interval [0,1]. c subroutine mv (n, v, w) integer n, j Double precision & v(n),w(n), one, four, six, h parameter (one = 1.0D+0 , four = 4.0D+0 , & six = 6.0D+0 ) c w(1) = four*v(1) + v(2) do 100 j = 2,n-1 w(j) = v(j-1) + four*v(j) + v(j+1) 100 continue j = n w(j) = v(j-1) + four*v(j) c c Scale the vector w by h. c h = one / (dble (n+1)*six) call dscal (n, h, w, 1) return end c c-------------------------------------------------------------------- c matrix vector subroutine c c The matrix used is the stiffness matrix obtained from the finite c element discretization of the 1-dimensional discrete Laplacian c on the interval [0,1] with zero Dirichlet boundary condition using c piecewise linear elements. c subroutine av (n, v, w) integer n, j Double precision & v(n),w(n), two, one, h parameter ( one = 1.0D+0 , two = 2.0D+0 ) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1 / h). c h = one / dble (n+1) call dscal (n, one/h, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/dsdrv4.f0000644000175000017500000004146607172774715017772 0ustar andreasandreas program dsdrv4 c c Program to illustrate the idea of reverse communication c in shift and invert mode for a generalized symmetric eigenvalue c problem. The following program uses the two LAPACK subroutines c dgttrf.f and dgttrs to factor and solve a tridiagonal system of c equations. c c We implement example four of ex-sym.doc in DOCUMENTS directory c c\Example-4 c ... Suppose we want to solve A*x = lambda*M*x in inverse mode, c where A and M are obtained from the finite element discretrization c of the 1-dimensional discrete Laplacian c d^2u / dx^2 c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c c ... OP = (inv[A - sigma*M])*M and B = M. c c ... Use mode 3 of DSAUPD. c c\BeginLib c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgttrf LAPACK tridiagonal factorization routine. c dgttrs LAPACK tridiagonal solve routine. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dcopy Level 1 BLAS that copies one vector to another. c dscal Level 1 BLAS that scales a vector by a scalar. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv4.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c---------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c Double precision & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Double precision & sigma, r1, r2, tol, h c c %------------% c | Parameters | c %------------% c Double precision & zero, one, two, four, six parameter (zero = 0.0D+0, one = 1.0D+0, & four = 4.0D+0, six = 6.0D+0, & two = 2.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dnrm2 external daxpy, dcopy, dscal, dnrm2, dgttrf, dgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'.) NEV is the number of eigenvalues (closest to | c | the shift SIGMA) to be approximated. Since the | c | shift-invert mode is used, WHICH is set to 'LM'. | c | The user can modify NEV, NCV, SIGMA to solve | c | problems of different sizes, and to get different | c | parts of the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = zero c c %--------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 specified in the | c | documentation of DSAUPD is used (IPARAM(7) = 3). | c | All these options may be changed by the user. | c | For details, see the documentation in DSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------------------% c | Call LAPACK routine to factor the tridiagonal matrix | c | (A-SIGMA*M). The matrix A is the 1-d discrete | c | Laplacian. The matrix M is the associated mass matrix | c | arising from using piecewise linear finite elements | c | on the interval [0, 1]. | c %-------------------------------------------------------% c h = one / dble(n+1) r1 = (four / six) * h r2 = (one / six) * h do 20 j=1,n ad(j) = two/h - sigma * r1 adl(j) = -one/h - sigma * r2 20 continue call dcopy (n, adl, 1, adu, 1) call dgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' Error with _gttrf in _SDRV4.' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dsaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1) then c c %--------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*M]*M*x | c | to force the starting vector into the | c | range of OP. The user should supply | c | his/her own matrix vector multiplication | c | routine and a linear system solver here. | c | The matrix vector multiplication routine | c | takes workd(ipntr(1)) as the input vector. | c | The final result is returned to | c | workd(ipntr(2)). | c %--------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c call dgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV4. ' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 1) then c c %-----------------------------------------% c | Perform y <-- OP*x = inv[A-sigma*M]*M*x | c | M*x has been saved in workd(ipntr(3)). | c | the user only needs the linear system | c | solver here that takes workd(ipntr(3) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call dcopy ( n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call dgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV4.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 2) then c c %-----------------------------------------% c | Perform y <--- M*x | c | Need the matrix vector multiplication | c | routine here that takes workd(ipntr(1)) | c | as the input and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check the documentation of _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call dseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd ' print *, ' ' c else c nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), workd) call mv(n, v(1,j), workd(n+1)) call daxpy (n, -d(j,1), workd(n+1), 1, workd, 1) d(j,2) = dnrm2(n, workd, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 30 continue c call dmout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') c end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV4 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dsdrv4. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c matrix vector subroutine c The matrix used is the 1 dimensional mass matrix c on the interval [0,1]. c subroutine mv (n, v, w) integer n, j Double precision & v(n),w(n), one, four, six, h parameter (one = 1.0D+0, four = 4.0D+0, & six = 6.0D+0) c w(1) = four*v(1) + v(2) do 100 j = 2,n-1 w(j) = v(j-1) + four*v(j) + v(j+1) 100 continue j = n w(j) = v(j-1) + four*v(j) c c Scale the vector w by h. c h = one / ( six*dble(n+1)) call dscal(n, h, w, 1) return end c------------------------------------------------------------------------ c matrix vector subroutine c where the matrix is the finite element discretization of the c 1 dimensional discrete Laplacian on [0,1] with zero Dirichlet c boundary condition using piecewise linear elements. c subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), two, one, h parameter (one = 1.0D+0, two = 2.0D+0) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1/h) c h = one / dble(n+1) call dscal(n, one/h, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/dsdrv5.f0000644000175000017500000004125007172775102017751 0ustar andreasandreas program dsdrv5 c c Program to illustrate the idea of reverse communication c in Buckling mode for a generalized symmetric eigenvalue c problem. The following program uses the two LAPACK subroutines c dgttrf.f and dgttrs.f to factor and solve a tridiagonal system of c equations. c c We implement example five of ex-sym.doc in DOCUMENTS directory c c\Example-5 c ... Suppose we want to solve K*x = lambda*KG*x in Buckling mode c where K and KG are obtained by the finite element of the c 1-dimensional discrete Laplacian c d^2u / dx^2 c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c ... OP = (inv[K - sigma*KG])*K and B = K. c ... Use mode 4 of DSAUPD. c c\BeginLib c c\References: c 1. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgttrf LAPACK tridiagonal factorization routine. c dgttrs LAPACK tridiagonal solve routine. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dcopy Level 1 BLAS that copies one vector to another. c dscal Level 1 BLAS that scales a vector by a scalar. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv5.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c---------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c Double precision & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn), & ax(maxn), mx(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Double precision & h, sigma, r1, r2, tol c c %------------% c | Parameters | c %------------% c Double precision & zero, one, two, four, six parameter (zero = 0.0D+0, one = 1.0D+0, & four = 4.0D+0, six = 6.0D+0, & two = 2.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dnrm2 external daxpy, dcopy, dscal, dnrm2, dgttrf, dgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'.) NEV is the number of eigenvalues to be | c | approximated. Since the buckling mode is used, | c | WHICH is set to 'LM'. The user can modify NEV, | c | NCV, SIGMA to solve problems of different sizes, | c | and to get different parts of the spectrum. | c | However, The following conditions must be | c | satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c | | c | The shift SIGMA cannot be zero!!! | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV5: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV5: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV5: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = one c c %-----------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 4 specified in the | c | documentation of DSAUPD is used (IPARAM(7) = 4). | c | All these options may be changed by the user. For | c | details, see the documentation in DSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 4 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------------------% c | Call LAPACK routine to factor the tridiagonal matrix | c | (K-SIGMA*KG). The matrix A is the 1-d discrete | c | Laplacian on the interval [0,1] with zero Dirichlet | c | boundary condition. The matrix M is the associated | c | mass matrix arising from using piecewise linear | c | finite elements on the interval [0, 1]. | c %------------------------------------------------------% c h = one / dble(n+1) r1 = (four / six) * h r2 = (one / six) * h do 20 j=1,n ad(j) = two / h - sigma * r1 adl(j) = -one / h- sigma * r2 20 continue call dcopy (n, adl, 1, adu, 1) call dgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrf in _SDRV5.' print *, ' ' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dsaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[K-SIGMA*KG]*K*x | c | to force starting vector into the range | c | of OP. The user should provide his/her | c | matrix vector multiplication routine and | c | a linear system solver here. The matrix | c | vector multiplication routine (K*x) takes | c | workd(ipntr(1)) as the input vector. The | c | final result is returned to | c | workd(ipntr(2)). | c %-------------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) c call dgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in SDRV5.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 1) then c c %------------------------------------------% c | Perform y <-- OP*x=inv(K-sigma*KG)*K*x. | c | K*x has been saved in workd(ipntr(3)). | c | The user only needs the linear system | c | solver here that takes workd(ipntr(3)) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %------------------------------------------% c call dcopy ( n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call dgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV5.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- K*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) c c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check the documentation of _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call dseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c if (ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ',ierr print *, ' Check the documentation of _seupd ' print *, ' ' c else c nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = dnrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 30 continue c call dmout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') c end if c c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV5 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is', n print *, ' The number of Ritz values requested is', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dsdrv5. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the 1-dimensional mass matrix c arising from using piecewise linear finite elements on the c interval [0,1]. c subroutine mv (n, v, w) integer n, j Double precision & v(n),w(n), one, four, six, h parameter (one = 1.0D+0, four = 4.0D+0, & six = 6.0D+0) c w(1) = four*v(1) + v(2) do 100 j = 2,n-1 w(j) = v(j-1) + four*v(j) + v(j+1) 100 continue j = n w(j) = v(j-1) + four*v(j) c c Scale the vector w by h. c h = one / (six*dble(n+1)) call dscal(n, h, w, 1) return end c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the stiffness matrix obtained from the c finite element discretization of the 1-dimensional discrete Laplacian c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), one, two, h parameter (one = 1.0D+0, two = 2.0D+0) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1/h) c h = one / (n+1) call dscal(n, one/h, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/dsdrv6.f0000644000175000017500000004305707172775277017776 0ustar andreasandreas program dsdrv6 c c Program to illustrate the idea of reverse communication c in Cayley mode for a generalized symmetric eigenvalue c problem. The following program uses the two LAPACK subroutines c dgttrf.f and dgttrs.f to factor and solve a tridiagonal system of c equations. c c We implement example six of ex-sym.doc in DOCUMENTS directory c c\Example-6 c ... Suppose we want to solve A*x = lambda*M*x in inverse mode, c where A and M are obtained by the finite element of the c 1-dimensional discrete Laplacian c d^2u / dx^2 c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c c ... OP = (inv[A-sigma*M])*(A+sigma*M) and B = M. c c ... Use mode 5 of DSAUPD. c c\BeginLib c c\References: c 1. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c c\Routines called: c dsaupd ARPACK reverse communication interface routine. c dseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c dgttrf LAPACK tridiagonal factorization routine. c dgttrs LAPACK tridiagonal solve routine. c daxpy Level 1 BLAS that computes y <- alpha*x+y. c dcopy Level 1 BLAS that copies one vector to another. c dscal Level 1 BLAS that scales a vector by a scalar. c dnrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv6.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c------------------------------------------------------------------------ c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c Double precision & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn), & temp(maxn), ax(maxn), mx(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Double precision & sigma, r1, r2, tol, h c c %------------% c | Parameters | c %------------% c Double precision & zero, one, two, four, six parameter (zero = 0.0D+0, one = 1.0D+0, & four = 4.0D+0, six = 6.0D+0, & two = 2.0D+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Double precision & dnrm2 external daxpy, dcopy, dscal, dnrm2, dgttrf, dgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'.) NEV is the number of eigenvalues to be | c | approximated. Since the Cayley mode is used, | c | WHICH is set to 'LM'. The user can modify NEV, | c | NCV, SIGMA to solve problems of different sizes, | c | and to get different parts of the spectrum. | c | However, The following conditions must be | c | satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV6: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV6: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV6: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = 1.5D+2 c c %--------------------------------------------------% c | The work array WORKL is used in DSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in DSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 5 specified in the | c | documentation of DSAUPD is used (IPARAM(7) = 5). | c | All these options may be changed by the user. For | c | details, see the documentation in DSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 5 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------------------% c | Call LAPACK routine to factor (A-sigma*M). The | c | stiffness matrix A is the 1-d discrete Laplacian. | c | The mass matrix M is the associated mass matrix | c | arising from using piecewise linear finite elements | c | on the interval [0, 1]. | c %------------------------------------------------------% c h = one / dble(n+1) r1 = (four / six) * h r2 = (one / six) * h do 20 j=1,n ad(j) = two / h - sigma * r1 adl(j) = -one / h - sigma * r2 20 continue call dcopy (n, adl, 1, adu, 1) call dgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrf in _SDRV6.' print *, ' ' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine DSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call dsaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1) then c c %-------------------------------------------------------% c | Perform y <--- OP*x = (inv[A-SIGMA*M])*(A+SIGMA*M)*x | c | to force starting vector into the range of OP. The | c | user should provide his/her matrix vector (A*x, M*x) | c | multiplication routines and a linear system solver | c | here. The matrix vector multiplication routine takes | c | workd(ipntr(1)) as the input vector. The final | c | result is returned to workd(ipntr(2)). | c %-------------------------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call mv (n, workd(ipntr(1)), temp) call daxpy(n, sigma, temp, 1, workd(ipntr(2)), 1) c call dgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV6.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 1) then c c %----------------------------------------------------% c | Perform y <-- OP*x = inv[A-SIGMA*M]*(A+SIGMA*M)*x. | c | M*x has been saved in workd(ipntr(3)). The user | c | need the matrix vector multiplication (A*x) | c | routine and a linear system solver here. The | c | matrix vector multiplication routine takes | c | workd(ipntr(1)) as the input, and the result is | c | combined with workd(ipntr(3)) to form the input | c | for the linear system solver. The final result is | c | returned to workd(ipntr(2)). | c %----------------------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call daxpy(n, sigma, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call dgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV6. ' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 2) then c c %--------------------------------------------% c | Perform y <--- M*x. | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %--------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call DSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in DSAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check the documentation of _saupd. ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using DSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call dseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of DSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd ' print *, ' ' c else c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c nconv = iparam(5) do 30 j=1, nconv call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call daxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = dnrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) 30 continue c call dmout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') c end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV6 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is', n print *, ' The number of Ritz values requested is', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program dsdrv6. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix used is the 1 dimensional mass matrix c arising from using the piecewise linear finite element c on the interval [0,1]. c subroutine mv (n, v, w) integer n, j Double precision & v(n), w(n), one, four, six, h parameter (one = 1.0D+0, four = 4.0D+0, & six = 6.0D+0) c w(1) = four*v(1) + v(2) do 100 j = 2,n-1 w(j) = v(j-1) + four*v(j) + v(j+1) 100 continue j = n w(j) = v(j-1) + four*v(j) c c Scale the vector w by h. c h = one / (six*dble(n+1)) call dscal(n, h, w, 1) return end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the stiffness matrix obtained from the c finite element discretization of the 1-dimensional discrete Laplacian c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c subroutine av (n, v, w) integer n, j Double precision & v(n), w(n), one, two, h parameter (one = 1.0D+0, two = 2.0D+0) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1/h). c h = one / dble(n+1) call dscal(n, one/h, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/ssdrv1.f0000644000175000017500000003406307172774146017777 0ustar andreasandreas program ssdrv1 c c Simple program to illustrate the idea of reverse communication c in regular mode for a standard symmetric eigenvalue problem. c c We implement example one of ex-sym.doc in SRC directory c c\Example-1 c ... Suppose we want to solve A*x = lambda*x in regular mode, c where A is derived from the central difference discretization c of the 2-dimensional Laplacian on the unit square [0,1]x[0,1] c with zero Dirichlet boundary condition. c c ... OP = A and B = I. c c ... Assume "call av (n,x,y)" computes y = A*x. c c ... Use mode 1 of SSAUPD. c c\BeginLib c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c snrm2 Level 1 BLAS that computes the norm of a vector. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c av Matrix vector multiplication routine that computes A*x. c tv Matrix vector multiplication routine that computes T*x, c where T is a tridiagonal matrix. It is used in routine c av. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv1.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c c----------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, $ ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Real & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ax(maxn) logical select(maxncv) integer iparam(11), ipntr(11) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, ierr, j, & nx, nconv, maxitr, mode, ishfts logical rvec Real & tol, sigma c c %------------% c | Parameters | c %------------% c Real & zero parameter (zero = 0.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & snrm2 external snrm2, saxpy c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------% c | The number NX is the number of interior points | c | in the discretization of the 2-dimensional | c | Laplacian on the unit square with zero Dirichlet | c | boundary condition. The number N(=NX*NX) is the | c | dimension of the matrix. A standard eigenvalue | c | problem is solved (BMAT = 'I'). NEV is the number | c | of eigenvalues to be approximated. The user can | c | modify NEV, NCV, WHICH to solve problems of | c | different sizes, and to get different parts of the | c | spectrum. However, The following conditions must | c | be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %----------------------------------------------------% c nx = 10 n = nx*nx nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV1: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV1: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV1: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'I' which = 'SM' c c %--------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero info = 0 ido = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 1 of SSAUPD is used | c | (IPARAM(7) = 1). All these options may be | c | changed by the user. For details, see the | c | documentation in SSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 1 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call ssaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %--------------------------------------% c | Perform matrix vector multiplication | c | y <--- OP*x | c | The user should supply his/her own | c | matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as | c | the input, and return the result to | c | workd(ipntr(2)). | c %--------------------------------------% c call av (nx, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message. Check the | c | documentation in SSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ', info print *, ' Check documentation in _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call sseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd. ' print *, ' ' c else c nconv = iparam(5) do 20 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(nx, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 20 continue c c %-------------------------------% c | Display computed residuals | c %-------------------------------% c call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV1 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program ssdrv1. | c %---------------------------% c 9000 continue c end c c ------------------------------------------------------------------ c matrix vector subroutine c c The matrix used is the 2 dimensional discrete Laplacian on unit c square with zero Dirichlet boundary condition. c c Computes w <--- OP*v, where OP is the nx*nx by nx*nx block c tridiagonal matrix c c | T -I | c |-I T -I | c OP = | -I T | c | ... -I| c | -I T| c c The subroutine TV is called to computed y<---T*x. c subroutine av (nx, v, w) integer nx, j, lo, n2 Real & v(nx*nx), w(nx*nx), one, h2 parameter ( one = 1.0E+0 ) c call tv(nx,v(1),w(1)) call saxpy(nx, -one, v(nx+1), 1, w(1), 1) c do 10 j = 2, nx-1 lo = (j-1)*nx call tv(nx, v(lo+1), w(lo+1)) call saxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1) call saxpy(nx, -one, v(lo+nx+1), 1, w(lo+1), 1) 10 continue c lo = (nx-1)*nx call tv(nx, v(lo+1), w(lo+1)) call saxpy(nx, -one, v(lo-nx+1), 1, w(lo+1), 1) c c Scale the vector w by (1/h^2), where h is the mesh size c n2 = nx*nx h2 = one / real((nx+1)*(nx+1)) call sscal(n2, one/h2, w, 1) return end c c------------------------------------------------------------------- subroutine tv (nx, x, y) c integer nx, j Real & x(nx), y(nx), dd, dl, du c Real & one parameter (one = 1.0E+0 ) c c Compute the matrix vector multiplication y<---T*x c where T is a nx by nx tridiagonal matrix with DD on the c diagonal, DL on the subdiagonal, and DU on the superdiagonal. c c dd = 4.0E+0 dl = -one du = -one c y(1) = dd*x(1) + du*x(2) do 10 j = 2,nx-1 y(j) = dl*x(j-1) + dd*x(j) + du*x(j+1) 10 continue y(nx) = dl*x(nx-1) + dd*x(nx) return end arpack-akloeckner-07/EXAMPLES/SYM/ssdrv2.f0000644000175000017500000003320407172774324017772 0ustar andreasandreas program ssdrv2 c c Program to illustrate the idea of reverse communication c in shift and invert mode for a standard symmetric eigenvalue c problem. The following program uses the two LAPACK subroutines c sgttrf.f and sgttrs.f to factor and solve a tridiagonal system of c equations. c c We implement example two of ex-sym.doc in DOCUMENTS directory c c\Example-2 c ... Suppose we want to solve A*x = lambda*x in shift-invert mode, c where A is derived from the central difference discretization c of the 1-dimensional Laplacian on [0,1] with zero Dirichlet c boundary condition. c ... OP = (inv[A - sigma*I]) and B = I. c ... Use mode 3 of SSAUPD. c c\BeginLib c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgttrf LAPACK tridiagonal factorization routine. c sgttrs LAPACK tridiagonal solve routine. c saxpy saxpy Level 1 BLAS that computes y <- alpha*x+y. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv2.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c---------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Real & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn), & ax(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Real & sigma, tol, h2 c c %------------% c | Parameters | c %------------% c Real & zero, one, two parameter (zero = 0.0E+0, one = 1.0E+0, & two = 2.0E+0) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & snrm2 external saxpy, snrm2, sgttrf, sgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable Statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | standard eigenvalue problem is solved (BMAT = 'I'. | c | NEV is the number of eigenvalues (closest to | c | SIGMA) to be approximated. Since the shift-invert | c | mode is used, WHICH is set to 'LM'. The user can | c | modify NEV, NCV, SIGMA to solve problems of | c | different sizes, and to get different parts of the | c | spectrum. However, The following conditions must | c | be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV2: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV2: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV2: NCV is greater than MAXNCV ' go to 9000 end if c bmat = 'I' which = 'LM' sigma = zero c c %--------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 of SSAUPD is used | c | (IPARAM(7) = 3). All these options may be | c | changed by the user. For details, see the | c | documentation in SSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-----------------------------------------------------% c | Call LAPACK routine to factor (A-SIGMA*I), where A | c | is the 1-d Laplacian. | c %-----------------------------------------------------% c h2 = one / real((n+1)*(n+1)) do 20 j=1,n ad(j) = two / h2 - sigma adl(j) = -one / h2 20 continue call scopy (n, adl, 1, adu, 1) call sgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrf in SDRV2.' print *, ' ' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call ssaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %----------------------------------------% c | Perform y <-- OP*x = inv[A-sigma*I]*x. | c | The user only need the linear system | c | solver here that takes workd(ipntr(1)) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %----------------------------------------% c call scopy (n, workd(ipntr(1)), 1, workd(ipntr(2)), 1) c call sgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV2. ' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %----------------------------------------% c | Either we have convergence or there is | c | an error. | c %----------------------------------------% c if ( info .lt. 0 ) then c c %----------------------------% c | Error message. Check the | c | documentation in SSAUPD | c %----------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check documentation of _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call sseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd ' print *, ' ' c else c nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call saxpy(n, -d(j,1), v(1,j), 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 30 continue c c %-------------------------------% c | Display computed residuals | c %-------------------------------% c call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV2 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program ssdrv2. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the 1 dimensional discrete Laplacian on c the interval [0,1] with zero Dirichlet boundary condition. c subroutine av (n, v, w) integer n, j Real & v(n), w(n), one, two, h2 parameter (one = 1.0E+0, two = 2.0E+0) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1 / h^2). c h2 = one / real((n+1)*(n+1)) call sscal(n, one/h2, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/ssdrv3.f0000644000175000017500000003734607174102004017764 0ustar andreasandreas program ssdrv3 c c Program to illustrate the idea of reverse communication in c inverse mode for a generalized symmetric eigenvalue problem. c The following program uses the two LAPACK subroutines sgttrf.f c and sgttrs.f to factor and solve a tridiagonal system of equations. c c We implement example three of ex-sym.doc in DOCUMENTS directory c c\Example-3 c ... Suppose we want to solve A*x = lambda*M*x in inverse mode, c where A and M are obtained by the finite element of the c 1-dimensional discrete Laplacian c d^2u / dx^2 c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c c ... OP = inv[M]*A and B = M. c c ... Use mode 2 of SSAUPD. c c\BeginLib c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgttrf LAPACK tridiagonal factorization routine. c sgttrs LAPACK tridiagonal solve routine. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c sscal Level 1 BLAS that scales a vector by a scalar. c scopy Level 1 BLAS that copies one vector to another. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv3.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c-------------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn ) c c %--------------% c | Local Arrays | c %--------------% c Real & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn), & ax(maxn), mx(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Real & sigma, r1, r2, tol, h c c %------------% c | Parameters | c %------------% c Real & zero, one, four, six parameter ( zero = 0.0E+0 , one = 1.0E+0 , & four = 4.0E+0 , six = 6.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & snrm2 external saxpy, scopy, sscal, snrm2, sgttrf, sgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'.) NEV is the number of eigenvalues to be | c | approximated. The user can modify NEV, NCV, WHICH | c | to solve problems of different sizes, and to get | c | different parts of the spectrum. However, The | c | following conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV3: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV3: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV3: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' c c %--------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 2 of SSAUPD is used | c | (IPARAM(7) = 2). All these options may be | c | changed by the user. For details, see the | c | documentation in SSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 2 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------------% c | Call LAPACK routine to factor the mass matrix. | c | The mass matrix is the tridiagonal matrix | c | arising from using piecewise linear finite | c | elements on the interval [0, 1]. | c %------------------------------------------------% c h = one / real (n+1) c r1 = (four / six) * h r2 = (one / six) * h do 20 j=1,n ad(j) = r1 adl(j) = r2 20 continue call scopy (n, adl, 1, adu, 1) call sgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrf in _SDRV3. ' print *, ' ' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call ssaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1 .or. ido .eq. 1) then c c %--------------------------------------% c | Perform y <--- OP*x = inv[M]*A*x. | c | The user should supply his/her own | c | matrix vector multiplication (A*x) | c | routine and a linear system solver | c | here. The matrix vector | c | multiplication routine takes | c | workd(ipntr(1)) as the input vector. | c | The final result is returned to | c | workd(ipntr(2)). The result of A*x | c | overwrites workd(ipntr(1)). | c %--------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call scopy(n, workd(ipntr(2)), 1, workd(ipntr(1)), 1) call sgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV3.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 2) then c c %-----------------------------------------% c | Perform y <--- M*x. | c | Need the matrix vector multiplication | c | routine here that takes workd(ipntr(1)) | c | as the input and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SSAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check the documentation of _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call sseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if (ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd' print *, ' ' c else c nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*M*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy(n, -d(j,1), mx, 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 30 continue c c %-----------------------------% c | Display computed residuals. | c %-----------------------------% c call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV3 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program ssdrv3. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the 1 dimensional mass matrix c on the interval [0,1]. c subroutine mv (n, v, w) integer n, j Real & v(n),w(n), one, four, six, h parameter (one = 1.0E+0 , four = 4.0E+0 , & six = 6.0E+0 ) c w(1) = four*v(1) + v(2) do 100 j = 2,n-1 w(j) = v(j-1) + four*v(j) + v(j+1) 100 continue j = n w(j) = v(j-1) + four*v(j) c c Scale the vector w by h. c h = one / (real (n+1)*six) call sscal(n, h, w, 1) return end c c-------------------------------------------------------------------- c matrix vector subroutine c c The matrix used is the stiffness matrix obtained from the finite c element discretization of the 1-dimensional discrete Laplacian c on the interval [0,1] with zero Dirichlet boundary condition using c piecewise linear elements. c subroutine av (n, v, w) integer n, j Real & v(n),w(n), two, one, h parameter ( one = 1.0E+0 , two = 2.0E+0 ) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1 / h). c h = one / real (n+1) call sscal(n, one/h, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/ssdrv4.f0000644000175000017500000004135607172774714020006 0ustar andreasandreas program ssdrv4 c c Program to illustrate the idea of reverse communication c in shift and invert mode for a generalized symmetric eigenvalue c problem. The following program uses the two LAPACK subroutines c sgttrf.f and sgttrs to factor and solve a tridiagonal system of c equations. c c We implement example four of ex-sym.doc in DOCUMENTS directory c c\Example-4 c ... Suppose we want to solve A*x = lambda*M*x in inverse mode, c where A and M are obtained from the finite element discretrization c of the 1-dimensional discrete Laplacian c d^2u / dx^2 c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c c ... OP = (inv[A - sigma*M])*M and B = M. c c ... Use mode 3 of SSAUPD. c c\BeginLib c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgttrf LAPACK tridiagonal factorization routine. c sgttrs LAPACK tridiagonal solve routine. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c scopy Level 1 BLAS that copies one vector to another. c sscal Level 1 BLAS that scales a vector by a scalar. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv4.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c---------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c Real & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Real & sigma, r1, r2, tol, h c c %------------% c | Parameters | c %------------% c Real & zero, one, two, four, six parameter (zero = 0.0E+0, one = 1.0E+0, & four = 4.0E+0, six = 6.0E+0, & two = 2.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & snrm2 external saxpy, scopy, sscal, snrm2, sgttrf, sgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %----------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'.) NEV is the number of eigenvalues (closest to | c | the shift SIGMA) to be approximated. Since the | c | shift-invert mode is used, WHICH is set to 'LM'. | c | The user can modify NEV, NCV, SIGMA to solve | c | problems of different sizes, and to get different | c | parts of the spectrum. However, The following | c | conditions must be satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %----------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV4: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV4: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV4: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = zero c c %--------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 3 specified in the | c | documentation of SSAUPD is used (IPARAM(7) = 3). | c | All these options may be changed by the user. | c | For details, see the documentation in SSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 3 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %-------------------------------------------------------% c | Call LAPACK routine to factor the tridiagonal matrix | c | (A-SIGMA*M). The matrix A is the 1-d discrete | c | Laplacian. The matrix M is the associated mass matrix | c | arising from using piecewise linear finite elements | c | on the interval [0, 1]. | c %-------------------------------------------------------% c h = one / real(n+1) r1 = (four / six) * h r2 = (one / six) * h do 20 j=1,n ad(j) = two/h - sigma * r1 adl(j) = -one/h - sigma * r2 20 continue call scopy (n, adl, 1, adu, 1) call sgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' Error with _gttrf in _SDRV4.' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call ssaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, & lworkl, info ) c if (ido .eq. -1) then c c %--------------------------------------------% c | Perform y <--- OP*x = inv[A-SIGMA*M]*M*x | c | to force the starting vector into the | c | range of OP. The user should supply | c | his/her own matrix vector multiplication | c | routine and a linear system solver here. | c | The matrix vector multiplication routine | c | takes workd(ipntr(1)) as the input vector. | c | The final result is returned to | c | workd(ipntr(2)). | c %--------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c call sgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV4. ' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 1) then c c %-----------------------------------------% c | Perform y <-- OP*x = inv[A-sigma*M]*M*x | c | M*x has been saved in workd(ipntr(3)). | c | the user only needs the linear system | c | solver here that takes workd(ipntr(3) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call scopy ( n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call sgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV4.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 2) then c c %-----------------------------------------% c | Perform y <--- M*x | c | Need the matrix vector multiplication | c | routine here that takes workd(ipntr(1)) | c | as the input and returns the result to | c | workd(ipntr(2)). | c %-----------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check the documentation of _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call sseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd ' print *, ' ' c else c nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), workd) call mv(n, v(1,j), workd(n+1)) call saxpy (n, -d(j,1), workd(n+1), 1, workd, 1) d(j,2) = snrm2(n, workd, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 30 continue c call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') c end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV4 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is ', n print *, ' The number of Ritz values requested is ', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is ', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program ssdrv4. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c matrix vector subroutine c The matrix used is the 1 dimensional mass matrix c on the interval [0,1]. c subroutine mv (n, v, w) integer n, j Real & v(n),w(n), one, four, six, h parameter (one = 1.0E+0, four = 4.0E+0, & six = 6.0E+0) c w(1) = four*v(1) + v(2) do 100 j = 2,n-1 w(j) = v(j-1) + four*v(j) + v(j+1) 100 continue j = n w(j) = v(j-1) + four*v(j) c c Scale the vector w by h. c h = one / ( six*real(n+1)) call sscal(n, h, w, 1) return end c------------------------------------------------------------------------ c matrix vector subroutine c where the matrix is the finite element discretization of the c 1 dimensional discrete Laplacian on [0,1] with zero Dirichlet c boundary condition using piecewise linear elements. c subroutine av (n, v, w) integer n, j Real & v(n), w(n), two, one, h parameter (one = 1.0E+0, two = 2.0E+0) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1/h) c h = one / real(n+1) call sscal(n, one/h, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/ssdrv5.f0000644000175000017500000004114007172775102017766 0ustar andreasandreas program ssdrv5 c c Program to illustrate the idea of reverse communication c in Buckling mode for a generalized symmetric eigenvalue c problem. The following program uses the two LAPACK subroutines c sgttrf.f and sgttrs.f to factor and solve a tridiagonal system of c equations. c c We implement example five of ex-sym.doc in DOCUMENTS directory c c\Example-5 c ... Suppose we want to solve K*x = lambda*KG*x in Buckling mode c where K and KG are obtained by the finite element of the c 1-dimensional discrete Laplacian c d^2u / dx^2 c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c ... OP = (inv[K - sigma*KG])*K and B = K. c ... Use mode 4 of SSAUPD. c c\BeginLib c c\References: c 1. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgttrf LAPACK tridiagonal factorization routine. c sgttrs LAPACK tridiagonal solve routine. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c scopy Level 1 BLAS that copies one vector to another. c sscal Level 1 BLAS that scales a vector by a scalar. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Richard Lehoucq c Danny Sorensen c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv5.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c---------------------------------------------------------------------- c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c Real & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn), & ax(maxn), mx(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Real & h, sigma, r1, r2, tol c c %------------% c | Parameters | c %------------% c Real & zero, one, two, four, six parameter (zero = 0.0E+0, one = 1.0E+0, & four = 4.0E+0, six = 6.0E+0, & two = 2.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & snrm2 external saxpy, scopy, sscal, snrm2, sgttrf, sgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'.) NEV is the number of eigenvalues to be | c | approximated. Since the buckling mode is used, | c | WHICH is set to 'LM'. The user can modify NEV, | c | NCV, SIGMA to solve problems of different sizes, | c | and to get different parts of the spectrum. | c | However, The following conditions must be | c | satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c | | c | The shift SIGMA cannot be zero!!! | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 10 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV5: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV5: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV5: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = one c c %-----------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication, and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi iteration. | c %-----------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 4 specified in the | c | documentation of SSAUPD is used (IPARAM(7) = 4). | c | All these options may be changed by the user. For | c | details, see the documentation in SSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 4 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------------------% c | Call LAPACK routine to factor the tridiagonal matrix | c | (K-SIGMA*KG). The matrix A is the 1-d discrete | c | Laplacian on the interval [0,1] with zero Dirichlet | c | boundary condition. The matrix M is the associated | c | mass matrix arising from using piecewise linear | c | finite elements on the interval [0, 1]. | c %------------------------------------------------------% c h = one / real(n+1) r1 = (four / six) * h r2 = (one / six) * h do 20 j=1,n ad(j) = two / h - sigma * r1 adl(j) = -one / h- sigma * r2 20 continue call scopy (n, adl, 1, adu, 1) call sgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrf in _SDRV5.' print *, ' ' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call ssaupd ( ido, bmat, n, which, nev, tol, resid, & ncv, v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1) then c c %-------------------------------------------% c | Perform y <--- OP*x = inv[K-SIGMA*KG]*K*x | c | to force starting vector into the range | c | of OP. The user should provide his/her | c | matrix vector multiplication routine and | c | a linear system solver here. The matrix | c | vector multiplication routine (K*x) takes | c | workd(ipntr(1)) as the input vector. The | c | final result is returned to | c | workd(ipntr(2)). | c %-------------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) c call sgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in SDRV5.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 1) then c c %------------------------------------------% c | Perform y <-- OP*x=inv(K-sigma*KG)*K*x. | c | K*x has been saved in workd(ipntr(3)). | c | The user only needs the linear system | c | solver here that takes workd(ipntr(3)) | c | as input, and returns the result to | c | workd(ipntr(2)). | c %------------------------------------------% c call scopy ( n, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call sgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV5.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 2) then c c %---------------------------------------------% c | Perform y <--- K*x | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %---------------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) c c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SSAUPD. | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check the documentation of _saupd ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call sseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c if (ierr .ne. 0) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ',ierr print *, ' Check the documentation of _seupd ' print *, ' ' c else c nconv = iparam(5) do 30 j=1, nconv c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) c 30 continue c call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') c end if c c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV5 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is', n print *, ' The number of Ritz values requested is', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program ssdrv5. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the 1-dimensional mass matrix c arising from using piecewise linear finite elements on the c interval [0,1]. c subroutine mv (n, v, w) integer n, j Real & v(n),w(n), one, four, six, h parameter (one = 1.0E+0, four = 4.0E+0, & six = 6.0E+0) c w(1) = four*v(1) + v(2) do 100 j = 2,n-1 w(j) = v(j-1) + four*v(j) + v(j+1) 100 continue j = n w(j) = v(j-1) + four*v(j) c c Scale the vector w by h. c h = one / (six*real(n+1)) call sscal(n, h, w, 1) return end c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the stiffness matrix obtained from the c finite element discretization of the 1-dimensional discrete Laplacian c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c subroutine av (n, v, w) integer n, j Real & v(n), w(n), one, two, h parameter (one = 1.0E+0, two = 2.0E+0) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1/h) c h = one / (n+1) call sscal(n, one/h, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/ssdrv6.f0000644000175000017500000004274707172775277020022 0ustar andreasandreas program ssdrv6 c c Program to illustrate the idea of reverse communication c in Cayley mode for a generalized symmetric eigenvalue c problem. The following program uses the two LAPACK subroutines c sgttrf.f and sgttrs.f to factor and solve a tridiagonal system of c equations. c c We implement example six of ex-sym.doc in DOCUMENTS directory c c\Example-6 c ... Suppose we want to solve A*x = lambda*M*x in inverse mode, c where A and M are obtained by the finite element of the c 1-dimensional discrete Laplacian c d^2u / dx^2 c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c c ... OP = (inv[A-sigma*M])*(A+sigma*M) and B = M. c c ... Use mode 5 of SSAUPD. c c\BeginLib c c\References: c 1. R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos c Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", c SIAM J. Matr. Anal. Apps., January (1993). c c\Routines called: c ssaupd ARPACK reverse communication interface routine. c sseupd ARPACK routine that returns Ritz values and (optionally) c Ritz vectors. c sgttrf LAPACK tridiagonal factorization routine. c sgttrs LAPACK tridiagonal solve routine. c saxpy Level 1 BLAS that computes y <- alpha*x+y. c scopy Level 1 BLAS that copies one vector to another. c sscal Level 1 BLAS that scales a vector by a scalar. c snrm2 Level 1 BLAS that computes the norm of a vector. c av Matrix vector multiplication routine that computes A*x. c mv Matrix vector multiplication routine that computes M*x. c c\Author c Danny Sorensen c Richard Lehoucq c Chao Yang c Dept. of Computational & c Applied Mathematics c Rice University c Houston, Texas c c\SCCS Information: @(#) c FILE: sdrv6.F SID: 2.5 DATE OF SID: 10/17/00 RELEASE: 2 c c\Remarks c 1. None c c\EndLib c------------------------------------------------------------------------ c c %-----------------------------% c | Define leading dimensions | c | for all arrays. | c | MAXN: Maximum dimension | c | of the A allowed. | c | MAXNEV: Maximum NEV allowed | c | MAXNCV: Maximum NCV allowed | c %-----------------------------% c integer maxn, maxnev, maxncv, ldv parameter (maxn=256, maxnev=10, maxncv=25, & ldv=maxn) c c %--------------% c | Local Arrays | c %--------------% c Real & v(ldv,maxncv), workl(maxncv*(maxncv+8)), & workd(3*maxn), d(maxncv,2), resid(maxn), & ad(maxn), adl(maxn), adu(maxn), adu2(maxn), & temp(maxn), ax(maxn), mx(maxn) logical select(maxncv) integer iparam(11), ipntr(11), ipiv(maxn) c c %---------------% c | Local Scalars | c %---------------% c character bmat*1, which*2 integer ido, n, nev, ncv, lworkl, info, j, ierr, & nconv, maxitr, ishfts, mode logical rvec Real & sigma, r1, r2, tol, h c c %------------% c | Parameters | c %------------% c Real & zero, one, two, four, six parameter (zero = 0.0E+0, one = 1.0E+0, & four = 4.0E+0, six = 6.0E+0, & two = 2.0E+0 ) c c %-----------------------------% c | BLAS & LAPACK routines used | c %-----------------------------% c Real & snrm2 external saxpy, scopy, sscal, snrm2, sgttrf, sgttrs c c %--------------------% c | Intrinsic function | c %--------------------% c intrinsic abs c c %-----------------------% c | Executable statements | c %-----------------------% c c %--------------------------------------------------% c | The number N is the dimension of the matrix. A | c | generalized eigenvalue problem is solved (BMAT = | c | 'G'.) NEV is the number of eigenvalues to be | c | approximated. Since the Cayley mode is used, | c | WHICH is set to 'LM'. The user can modify NEV, | c | NCV, SIGMA to solve problems of different sizes, | c | and to get different parts of the spectrum. | c | However, The following conditions must be | c | satisfied: | c | N <= MAXN, | c | NEV <= MAXNEV, | c | NEV + 1 <= NCV <= MAXNCV | c %--------------------------------------------------% c n = 100 nev = 4 ncv = 20 if ( n .gt. maxn ) then print *, ' ERROR with _SDRV6: N is greater than MAXN ' go to 9000 else if ( nev .gt. maxnev ) then print *, ' ERROR with _SDRV6: NEV is greater than MAXNEV ' go to 9000 else if ( ncv .gt. maxncv ) then print *, ' ERROR with _SDRV6: NCV is greater than MAXNCV ' go to 9000 end if bmat = 'G' which = 'LM' sigma = 1.5E+2 c c %--------------------------------------------------% c | The work array WORKL is used in SSAUPD as | c | workspace. Its dimension LWORKL is set as | c | illustrated below. The parameter TOL determines | c | the stopping criterion. If TOL<=0, machine | c | precision is used. The variable IDO is used for | c | reverse communication and is initially set to 0. | c | Setting INFO=0 indicates that a random vector is | c | generated in SSAUPD to start the Arnoldi | c | iteration. | c %--------------------------------------------------% c lworkl = ncv*(ncv+8) tol = zero ido = 0 info = 0 c c %---------------------------------------------------% c | This program uses exact shifts with respect to | c | the current Hessenberg matrix (IPARAM(1) = 1). | c | IPARAM(3) specifies the maximum number of Arnoldi | c | iterations allowed. Mode 5 specified in the | c | documentation of SSAUPD is used (IPARAM(7) = 5). | c | All these options may be changed by the user. For | c | details, see the documentation in SSAUPD. | c %---------------------------------------------------% c ishfts = 1 maxitr = 300 mode = 5 c iparam(1) = ishfts iparam(3) = maxitr iparam(7) = mode c c %------------------------------------------------------% c | Call LAPACK routine to factor (A-sigma*M). The | c | stiffness matrix A is the 1-d discrete Laplacian. | c | The mass matrix M is the associated mass matrix | c | arising from using piecewise linear finite elements | c | on the interval [0, 1]. | c %------------------------------------------------------% c h = one / real(n+1) r1 = (four / six) * h r2 = (one / six) * h do 20 j=1,n ad(j) = two / h - sigma * r1 adl(j) = -one / h - sigma * r2 20 continue call scopy (n, adl, 1, adu, 1) call sgttrf (n, adl, ad, adu, adu2, ipiv, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrf in _SDRV6.' print *, ' ' go to 9000 end if c c %-------------------------------------------% c | M A I N L O O P (Reverse communication) | c %-------------------------------------------% c 10 continue c c %---------------------------------------------% c | Repeatedly call the routine SSAUPD and take | c | actions indicated by parameter IDO until | c | either convergence is indicated or maxitr | c | has been exceeded. | c %---------------------------------------------% c call ssaupd ( ido, bmat, n, which, nev, tol, resid, ncv, & v, ldv, iparam, ipntr, workd, workl, lworkl, & info ) c if (ido .eq. -1) then c c %-------------------------------------------------------% c | Perform y <--- OP*x = (inv[A-SIGMA*M])*(A+SIGMA*M)*x | c | to force starting vector into the range of OP. The | c | user should provide his/her matrix vector (A*x, M*x) | c | multiplication routines and a linear system solver | c | here. The matrix vector multiplication routine takes | c | workd(ipntr(1)) as the input vector. The final | c | result is returned to workd(ipntr(2)). | c %-------------------------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call mv (n, workd(ipntr(1)), temp) call saxpy(n, sigma, temp, 1, workd(ipntr(2)), 1) c call sgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV6.' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 1) then c c %----------------------------------------------------% c | Perform y <-- OP*x = inv[A-SIGMA*M]*(A+SIGMA*M)*x. | c | M*x has been saved in workd(ipntr(3)). The user | c | need the matrix vector multiplication (A*x) | c | routine and a linear system solver here. The | c | matrix vector multiplication routine takes | c | workd(ipntr(1)) as the input, and the result is | c | combined with workd(ipntr(3)) to form the input | c | for the linear system solver. The final result is | c | returned to workd(ipntr(2)). | c %----------------------------------------------------% c call av (n, workd(ipntr(1)), workd(ipntr(2))) call saxpy(n, sigma, workd(ipntr(3)), 1, workd(ipntr(2)), 1) call sgttrs ('Notranspose', n, 1, adl, ad, adu, adu2, ipiv, & workd(ipntr(2)), n, ierr) if (ierr .ne. 0) then print *, ' ' print *, ' Error with _gttrs in _SDRV6. ' print *, ' ' go to 9000 end if c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c else if (ido .eq. 2) then c c %--------------------------------------------% c | Perform y <--- M*x. | c | Need matrix vector multiplication routine | c | here that takes workd(ipntr(1)) as input | c | and returns the result to workd(ipntr(2)). | c %--------------------------------------------% c call mv (n, workd(ipntr(1)), workd(ipntr(2))) c c %-----------------------------------------% c | L O O P B A C K to call SSAUPD again. | c %-----------------------------------------% c go to 10 c end if c c %-----------------------------------------% c | Either we have convergence, or there is | c | an error. | c %-----------------------------------------% c if ( info .lt. 0 ) then c c %--------------------------% c | Error message, check the | c | documentation in SSAUPD | c %--------------------------% c print *, ' ' print *, ' Error with _saupd, info = ',info print *, ' Check the documentation of _saupd. ' print *, ' ' c else c c %-------------------------------------------% c | No fatal errors occurred. | c | Post-Process using SSEUPD. | c | | c | Computed eigenvalues may be extracted. | c | | c | Eigenvectors may also be computed now if | c | desired. (indicated by rvec = .true.) | c %-------------------------------------------% c rvec = .true. c call sseupd ( rvec, 'All', select, d, v, ldv, sigma, & bmat, n, which, nev, tol, resid, ncv, v, ldv, & iparam, ipntr, workd, workl, lworkl, ierr ) c c %----------------------------------------------% c | Eigenvalues are returned in the first column | c | of the two dimensional array D and the | c | corresponding eigenvectors are returned in | c | the first NEV columns of the two dimensional | c | array V if requested. Otherwise, an | c | orthogonal basis for the invariant subspace | c | corresponding to the eigenvalues in D is | c | returned in V. | c %----------------------------------------------% c if ( ierr .ne. 0 ) then c c %------------------------------------% c | Error condition: | c | Check the documentation of SSEUPD. | c %------------------------------------% c print *, ' ' print *, ' Error with _seupd, info = ', ierr print *, ' Check the documentation of _seupd ' print *, ' ' c else c c %---------------------------% c | Compute the residual norm | c | | c | || A*x - lambda*x || | c | | c | for the NCONV accurately | c | computed eigenvalues and | c | eigenvectors. (iparam(5) | c | indicates how many are | c | accurate to the requested | c | tolerance) | c %---------------------------% c nconv = iparam(5) do 30 j=1, nconv call av(n, v(1,j), ax) call mv(n, v(1,j), mx) call saxpy (n, -d(j,1), mx, 1, ax, 1) d(j,2) = snrm2(n, ax, 1) d(j,2) = d(j,2) / abs(d(j,1)) 30 continue c call smout(6, nconv, 2, d, maxncv, -6, & 'Ritz values and relative residuals') c end if c c %------------------------------------------% c | Print additional convergence information | c %------------------------------------------% c if ( info .eq. 1) then print *, ' ' print *, ' Maximum number of iterations reached.' print *, ' ' else if ( info .eq. 3) then print *, ' ' print *, ' No shifts could be applied during implicit', & ' Arnoldi update, try increasing NCV.' print *, ' ' end if c print *, ' ' print *, ' _SDRV6 ' print *, ' ====== ' print *, ' ' print *, ' Size of the matrix is', n print *, ' The number of Ritz values requested is', nev print *, ' The number of Arnoldi vectors generated', & ' (NCV) is ', ncv print *, ' What portion of the spectrum: ', which print *, ' The number of converged Ritz values is ', & nconv print *, ' The number of Implicit Arnoldi update', & ' iterations taken is', iparam(3) print *, ' The number of OP*x is ', iparam(9) print *, ' The convergence criterion is ', tol print *, ' ' c end if c c %---------------------------% c | Done with program ssdrv6. | c %---------------------------% c 9000 continue c end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix used is the 1 dimensional mass matrix c arising from using the piecewise linear finite element c on the interval [0,1]. c subroutine mv (n, v, w) integer n, j Real & v(n), w(n), one, four, six, h parameter (one = 1.0E+0, four = 4.0E+0, & six = 6.0E+0) c w(1) = four*v(1) + v(2) do 100 j = 2,n-1 w(j) = v(j-1) + four*v(j) + v(j+1) 100 continue j = n w(j) = v(j-1) + four*v(j) c c Scale the vector w by h. c h = one / (six*real(n+1)) call sscal(n, h, w, 1) return end c c------------------------------------------------------------------------ c Matrix vector subroutine c where the matrix is the stiffness matrix obtained from the c finite element discretization of the 1-dimensional discrete Laplacian c on the interval [0,1] with zero Dirichlet boundary condition c using piecewise linear elements. c subroutine av (n, v, w) integer n, j Real & v(n), w(n), one, two, h parameter (one = 1.0E+0, two = 2.0E+0) c w(1) = two*v(1) - v(2) do 100 j = 2,n-1 w(j) = - v(j-1) + two*v(j) - v(j+1) 100 continue j = n w(j) = - v(j-1) + two*v(j) c c Scale the vector w by (1/h). c h = one / real(n+1) call sscal(n, one/h, w, 1) return end arpack-akloeckner-07/EXAMPLES/SYM/makefile0000644000175000017500000000322006206636211020060 0ustar andreasandreas# # makefile to run simple examples of the reverse communication # protocol. # # Modify if ARPACK library was built somewhere else. # We assume that the required BLAS and LAPACK routines # are in the version of libarpack.a built. If not, you # will need to modify the link step below and link to them. # #\SCCS Information: @(#) # FILE: makefile SID: 2.1 DATE OF SID: 11/19/95 RELEASE: 2 # include ../../ARmake.inc # # Issue "make sym" to make all 12 symmetric drivers # Issue "make ssdrv" to make 6 single precision symmetric drivers # Issue "make dsdrv" to make 6 double precision symmetric drivers # sym: ssdrv dsdrv # # simple symmetric problem using single precision # ssdrv: ssdrv1 ssdrv2 ssdrv3 ssdrv4 ssdrv5 ssdrv6 ssdrv1: ssdrv1.o $(FC) $(FFLAGS) ssdrv1.o $(ALIBS) -o ssdrv1 # ssdrv2: ssdrv2.o $(FC) $(FFLAGS) ssdrv2.o $(ALIBS) -o ssdrv2 # ssdrv3: ssdrv3.o $(FC) $(FFLAGS) ssdrv3.o $(ALIBS) -o ssdrv3 # ssdrv4: ssdrv4.o $(FC) $(FFLAGS) ssdrv4.o $(ALIBS) -o ssdrv4 # ssdrv5: ssdrv5.o $(FC) $(FFLAGS) ssdrv5.o $(ALIBS) -o ssdrv5 # ssdrv6: ssdrv6.o $(FC) $(FFLAGS) ssdrv6.o $(ALIBS) -o ssdrv6 # #----------------------------------------------------------------------- # simple symmetric problem using double precision # dsdrv: dsdrv1 dsdrv2 dsdrv3 dsdrv4 dsdrv5 dsdrv6 dsdrv1: dsdrv1.o $(FC) $(FFLAGS) dsdrv1.o $(ALIBS) -o dsdrv1 # dsdrv2: dsdrv2.o $(FC) $(FFLAGS) dsdrv2.o $(ALIBS) -o dsdrv2 # dsdrv3: dsdrv3.o $(FC) $(FFLAGS) dsdrv3.o $(ALIBS) -o dsdrv3 # dsdrv4: dsdrv4.o $(FC) $(FFLAGS) dsdrv4.o $(ALIBS) -o dsdrv4 # dsdrv5: dsdrv5.o $(FC) $(FFLAGS) dsdrv5.o $(ALIBS) -o dsdrv5 # dsdrv6: dsdrv6.o $(FC) $(FFLAGS) dsdrv6.o $(ALIBS) -o dsdrv6 arpack-akloeckner-07/EXAMPLES/SYM/README0000644000175000017500000000413506053471261017250 0ustar andreasandreas1. Purpose ------- This directory contains example drivers that call ARPACK subroutines [s,d]saupd.f and [s,d]seupd.f to solve SYMMETRIC eigenvalue problems using regular, inverse, shift-invert or other special modes (such as Cayley, Bucking etc.) These drivers illustrate how to set various ARPACK parameters to solve different problems in different modes. They provide a guideline on how to use ARPACK's reverse communication interface. The user may modify any one of these drivers, and provide his/her own matrix vector multiplication routine to solve the problem of his/her own interest. 2. Naming convention ----------------- The name for each driver has the form 'XsdrvN.f', where X - is 's' (single precision) or 'd' (double precision) N - is a number between 1 and 6. If N = 1, the driver solves a STANDARD eigenvalue problem in REGULAR mode N = 2, the driver solves a STANDARD eigenvalue problem in SHIFT-INVERT mode. N = 3, the driver solves a GENERALIZED eigenvalue problem in INVERSE mode N = 4, the driver solves a GENERALIZED eigenvalue problem in SHIFT-INVERT mode. These are 4 commonly used drivers. For shift-invert (N=2,4) mode the user needs to supply a linear system solver to perform y=inv[A-sigma*B]*x. When N > 4, a special mode is used. If N = 5, the driver solves a GENERALIZED eigenvalue problem in BUCKLING mode. N = 6, the driver solves a GENERALIZED eigenvalue problem in CAYLEY mode. These two drivers require the user to provide linear system solvers also. For more information on Cayley and Buckling mode, see the following reference: R.G. Grimes, J.G. Lewis and H.D. Simon, "A Shifted Block Lanczos Algorithm for Solving Sparse Symmetric Generalized Eigenproblems", SIAM J. Matr. Anal. Apps., January (1993). 3. Usage ----- To run these drivers, you may use the makefile in this directory and issue, for example, "make ssdrv1". Then execute using "ssdrv1". arpack-akloeckner-07/Makefile0000644000175000017500000000404110670623764016145 0ustar andreasandreas############################################################################ # # Program: ARPACK # # Module: Makefile # # Purpose: Top-level Makefile # # Creation date: February 22, 1996 # # Modified: # # Send bug reports, comments or suggestions to arpack@caam.rice.edu # ############################################################################ include ARmake.inc PRECISIONS = single double complex complex16 #PRECISIONS = double ddrv # If LAPACK and BLAS are not installed on you system, and you are going # to use the driver programs in the EXAMPLES directory, you need to add # sdrv(for single precision), ddrv(for double precision), # cdrv(for single precision complex), or zdrv(for double precision complex) # to the definition of PRECISION. ############################################################################ # # The library can be set up to include routines for any combination of the # four PRECISIONS. First, modify the definitions in ARmake.inc to match # your library archiver, compiler, and the options to be used. # # Sample ARmake.inc's can be found in the directory ARMAKES # # Then to create or add to the library, enter make lib after having # modified the environment variable PRECISIONS defined in this Makefile. # # make lib # creates the library for serial ARPACK, # # The name of the libraries are defined in the file called ARmake.inc and # are created at this directory level. # # To remove the object files after the libraries and testing executables # are created, enter # make clean # ############################################################################ all: lib lib: arpacklib clean: cleanlib arpacklib: @( \ for f in $(DIRS); \ do \ $(CD) $$f; \ $(ECHO) Making lib in $$f; \ $(MAKE) $(PRECISIONS); \ $(CD) ..; \ done ); $(RANLIB) $(ARPACKLIB) cleantest: cleanlib: ( cd $(BLASdir); $(MAKE) clean ) ( cd $(LAPACKdir); $(MAKE) clean ) ( cd $(UTILdir); $(MAKE) clean ) ( cd $(SRCdir); $(MAKE) clean ) help: @$(ECHO) "usage: make ?"