From 300a2b5185f39d467d4c3e4048b3d28a9365c88f Mon Sep 17 00:00:00 2001 From: Nicholas Malaya Date: Sat, 4 Feb 2012 00:36:40 +0000 Subject: [PATCH] [cantera]: removing deprecated lapack --- Cantera/ext/lapack/Makefile.am | 28 -- Cantera/ext/lapack/dbdsqr.f | 807 ------------------------------- Cantera/ext/lapack/dgbsv.f | 144 ------ Cantera/ext/lapack/dgbtf2.f | 203 -------- Cantera/ext/lapack/dgbtrf.f | 442 ----------------- Cantera/ext/lapack/dgbtrs.f | 187 ------- Cantera/ext/lapack/dgebd2.f | 238 --------- Cantera/ext/lapack/dgebrd.f | 258 ---------- Cantera/ext/lapack/dgelq2.f | 122 ----- Cantera/ext/lapack/dgelqf.f | 186 ------- Cantera/ext/lapack/dgelss.f | 604 ----------------------- Cantera/ext/lapack/dgeqr2.f | 122 ----- Cantera/ext/lapack/dgeqrf.f | 187 ------- Cantera/ext/lapack/dgetf2.f | 135 ------ Cantera/ext/lapack/dgetrf.f | 160 ------ Cantera/ext/lapack/dgetri.f | 801 ------------------------------ Cantera/ext/lapack/dgetrs.f | 150 ------ Cantera/ext/lapack/dlabad.f | 56 --- Cantera/ext/lapack/dlabrd.f | 291 ----------- Cantera/ext/lapack/dlacpy.f | 88 ---- Cantera/ext/lapack/dlamch.f | 857 --------------------------------- Cantera/ext/lapack/dlange.f | 145 ------ Cantera/ext/lapack/dlapy2.f | 54 --- Cantera/ext/lapack/dlarf.f | 116 ----- Cantera/ext/lapack/dlarfb.f | 588 ---------------------- Cantera/ext/lapack/dlarfg.f | 138 ------ Cantera/ext/lapack/dlarft.f | 218 --------- Cantera/ext/lapack/dlartg.f | 143 ------ Cantera/ext/lapack/dlas2.f | 122 ----- Cantera/ext/lapack/dlascl.f | 268 ----------- Cantera/ext/lapack/dlaset.f | 115 ----- Cantera/ext/lapack/dlasq1.f | 222 --------- Cantera/ext/lapack/dlasq2.f | 268 ----------- Cantera/ext/lapack/dlasq3.f | 820 ------------------------------- Cantera/ext/lapack/dlasq4.f | 103 ---- Cantera/ext/lapack/dlasr.f | 325 ------------- Cantera/ext/lapack/dlasrt.f | 244 ---------- Cantera/ext/lapack/dlassq.f | 89 ---- Cantera/ext/lapack/dlasv2.f | 250 ---------- Cantera/ext/lapack/dlaswp.f | 120 ----- Cantera/ext/lapack/dorg2r.f | 130 ----- Cantera/ext/lapack/dorgbr.f | 223 --------- Cantera/ext/lapack/dorgl2.f | 134 ------ Cantera/ext/lapack/dorglq.f | 207 -------- Cantera/ext/lapack/dorgqr.f | 208 -------- Cantera/ext/lapack/dorm2r.f | 198 -------- Cantera/ext/lapack/dormbr.f | 250 ---------- Cantera/ext/lapack/dorml2.f | 198 -------- Cantera/ext/lapack/dormlq.f | 254 ---------- Cantera/ext/lapack/dormqr.f | 247 ---------- Cantera/ext/lapack/drscl.f | 115 ----- Cantera/ext/lapack/ilaenv.f | 506 ------------------- Cantera/ext/lapack/lsame.f | 87 ---- Cantera/ext/lapack/xerbla.f | 46 -- 54 files changed, 13217 deletions(-) delete mode 100644 Cantera/ext/lapack/Makefile.am delete mode 100755 Cantera/ext/lapack/dbdsqr.f delete mode 100755 Cantera/ext/lapack/dgbsv.f delete mode 100755 Cantera/ext/lapack/dgbtf2.f delete mode 100755 Cantera/ext/lapack/dgbtrf.f delete mode 100755 Cantera/ext/lapack/dgbtrs.f delete mode 100755 Cantera/ext/lapack/dgebd2.f delete mode 100755 Cantera/ext/lapack/dgebrd.f delete mode 100755 Cantera/ext/lapack/dgelq2.f delete mode 100755 Cantera/ext/lapack/dgelqf.f delete mode 100755 Cantera/ext/lapack/dgelss.f delete mode 100755 Cantera/ext/lapack/dgeqr2.f delete mode 100755 Cantera/ext/lapack/dgeqrf.f delete mode 100755 Cantera/ext/lapack/dgetf2.f delete mode 100755 Cantera/ext/lapack/dgetrf.f delete mode 100755 Cantera/ext/lapack/dgetri.f delete mode 100755 Cantera/ext/lapack/dgetrs.f delete mode 100755 Cantera/ext/lapack/dlabad.f delete mode 100755 Cantera/ext/lapack/dlabrd.f delete mode 100755 Cantera/ext/lapack/dlacpy.f delete mode 100755 Cantera/ext/lapack/dlamch.f delete mode 100755 Cantera/ext/lapack/dlange.f delete mode 100755 Cantera/ext/lapack/dlapy2.f delete mode 100755 Cantera/ext/lapack/dlarf.f delete mode 100755 Cantera/ext/lapack/dlarfb.f delete mode 100755 Cantera/ext/lapack/dlarfg.f delete mode 100755 Cantera/ext/lapack/dlarft.f delete mode 100755 Cantera/ext/lapack/dlartg.f delete mode 100755 Cantera/ext/lapack/dlas2.f delete mode 100755 Cantera/ext/lapack/dlascl.f delete mode 100755 Cantera/ext/lapack/dlaset.f delete mode 100755 Cantera/ext/lapack/dlasq1.f delete mode 100755 Cantera/ext/lapack/dlasq2.f delete mode 100755 Cantera/ext/lapack/dlasq3.f delete mode 100755 Cantera/ext/lapack/dlasq4.f delete mode 100755 Cantera/ext/lapack/dlasr.f delete mode 100755 Cantera/ext/lapack/dlasrt.f delete mode 100755 Cantera/ext/lapack/dlassq.f delete mode 100755 Cantera/ext/lapack/dlasv2.f delete mode 100755 Cantera/ext/lapack/dlaswp.f delete mode 100755 Cantera/ext/lapack/dorg2r.f delete mode 100755 Cantera/ext/lapack/dorgbr.f delete mode 100755 Cantera/ext/lapack/dorgl2.f delete mode 100755 Cantera/ext/lapack/dorglq.f delete mode 100755 Cantera/ext/lapack/dorgqr.f delete mode 100755 Cantera/ext/lapack/dorm2r.f delete mode 100755 Cantera/ext/lapack/dormbr.f delete mode 100755 Cantera/ext/lapack/dorml2.f delete mode 100755 Cantera/ext/lapack/dormlq.f delete mode 100755 Cantera/ext/lapack/dormqr.f delete mode 100755 Cantera/ext/lapack/drscl.f delete mode 100755 Cantera/ext/lapack/ilaenv.f delete mode 100755 Cantera/ext/lapack/lsame.f delete mode 100755 Cantera/ext/lapack/xerbla.f diff --git a/Cantera/ext/lapack/Makefile.am b/Cantera/ext/lapack/Makefile.am deleted file mode 100644 index 650ece62c..000000000 --- a/Cantera/ext/lapack/Makefile.am +++ /dev/null @@ -1,28 +0,0 @@ -fc_sources = dbdsqr.f dgbtrf.f dgbtf2.f dgbtrs.f dgbsv.f \ - dgebd2.f dgebrd.f dgelq2.f dgelqf.f dgelss.f \ - dgeqr2.f dgeqrf.f dgetf2.f dgetrf.f dgetri.f \ - dgetrs.f dlabad.f dlabrd.f dlacpy.f dlamch.f \ - dlange.f dlapy2.f dlarf.f dlarfb.f dlarfg.f \ - dlarft.f dlartg.f dlas2.f dlascl.f dlaset.f \ - dlasq1.f dlasq2.f dlasq3.f dlasq4.f dlasr.f \ - dlasrt.f dlassq.f dlasv2.f dlaswp.f dorg2r.f \ - dorgbr.f dorgl2.f dorglq.f dorgqr.f dorm2r.f \ - dormbr.f dorml2.f dormlq.f dormqr.f drscl.f \ - ilaenv.f - -AM_CPPFLAGS = -AM_CXXFLAGS = $(AM_CPPFLAGS) -AM_FCFLAGS = $(AM_CPPFLAGS) - -lib_LTLIBRARIES = $(top_builddir)/build/lib/libctlapack.la -library_includedir = $(top_builddir)/build/include -library_include_HEADERS = $(h_sources) - -#----------------------- -# Cantera Converters C/C++ library -#----------------------- - -__top_builddir__build_lib_libctlapack_la_LDFLAGS = $(all_libraries) -release $(GENERIC_RELEASE) -__top_builddir__build_lib_libctlapack_la_SOURCES = $(fc_sources) $(cc_sources) - -CLEANFILES = *.o diff --git a/Cantera/ext/lapack/dbdsqr.f b/Cantera/ext/lapack/dbdsqr.f deleted file mode 100755 index e89063a7f..000000000 --- a/Cantera/ext/lapack/dbdsqr.f +++ /dev/null @@ -1,807 +0,0 @@ - SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, - $ LDU, 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 UPLO - INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. -* -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given real input matrices U, VT, and C. -* -* See "Computing Small Singular Values of Bidiagonal Matrices With -* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, -* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, -* no. 5, pp. 873-912, Sept 1990) and -* "Accurate singular values and differential qd algorithms," by -* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics -* Department, University of California at Berkeley, July 1992 -* for a detailed description of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': B is upper bidiagonal; -* = 'L': B is lower bidiagonal. -* -* N (input) INTEGER -* The order of the matrix B. N >= 0. -* -* NCVT (input) INTEGER -* The number of columns of the matrix VT. NCVT >= 0. -* -* NRU (input) INTEGER -* The number of rows of the matrix U. NRU >= 0. -* -* NCC (input) INTEGER -* The number of columns of the matrix C. NCC >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the bidiagonal matrix B. -* On exit, if INFO=0, the singular values of B in decreasing -* order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E -* will contain the diagonal and superdiagonal elements of a -* bidiagonal matrix orthogonally equivalent to the one given -* as input. E(N) is used for workspace. -* -* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) -* On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. -* -* LDVT (input) INTEGER -* The leading dimension of the array VT. -* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. -* -* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) -* On entry, an NRU-by-N matrix U. -* On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. -* -* LDU (input) INTEGER -* The leading dimension of the array U. LDU >= max(1,NRU). -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) -* On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. -* -* LDC (input) INTEGER -* The leading dimension of the array C. -* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* 2*N if only singular values wanted (NCVT = NRU = NCC = 0) -* max( 1, 4*N-4 ) otherwise -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: If INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm did not converge; D and E contain the -* elements of a bidiagonal matrix which is orthogonally -* similar to the input matrix B; if INFO = i, i -* elements of E have not converged to zero. -* -* Internal Parameters -* =================== -* -* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) -* TOLMUL controls the convergence criterion of the QR loop. -* If it is positive, TOLMUL*EPS is the desired relative -* precision in the computed singular values. -* If it is negative, abs(TOLMUL*EPS*sigma_max) is the -* desired absolute accuracy in the computed singular -* values (corresponds to relative accuracy -* abs(TOLMUL*EPS) in the largest singular value. -* abs(TOLMUL) should be between 1 and 1/EPS, and preferably -* between 10 (for fast convergence) and .1/EPS -* (for there to be some accuracy in the results). -* Default is to lose at either one eighth or 2 of the -* available decimal digits in each computed singular value -* (whichever is smaller). -* -* MAXITR INTEGER, default = 6 -* MAXITR controls the maximum number of passes of the -* algorithm through its inner loop. The algorithms stops -* (and so fails to converge) if the number of passes -* through the inner loop exceeds MAXITR*N**2. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION NEGONE - PARAMETER ( NEGONE = -1.0D0 ) - DOUBLE PRECISION HNDRTH - PARAMETER ( HNDRTH = 0.01D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HNDRD - PARAMETER ( HNDRD = 100.0D0 ) - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - INTEGER MAXITR - PARAMETER ( MAXITR = 6 ) -* .. -* .. Local Scalars .. - LOGICAL ROTATE - INTEGER I, IDIR, IROT, ISUB, ITER, IUPLO, J, LL, LLL, - $ M, MAXIT, NM1, NM12, NM13, OLDLL, OLDM - DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, - $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, - $ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, - $ SN, THRESH, TOL, TOLMUL, UNFL -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, - $ DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IUPLO = 0 - IF( LSAME( UPLO, 'U' ) ) - $ IUPLO = 1 - IF( LSAME( UPLO, 'L' ) ) - $ IUPLO = 2 - IF( IUPLO.EQ.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NCVT.LT.0 ) THEN - INFO = -3 - ELSE IF( NRU.LT.0 ) THEN - INFO = -4 - ELSE IF( NCC.LT.0 ) THEN - INFO = -5 - ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. - $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN - INFO = -11 - ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. - $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DBDSQR', -INFO ) - RETURN - END IF - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) - $ GO TO 150 -* -* ROTATE is true if any singular vectors desired, false otherwise -* - ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) -* -* If no singular vectors desired, use qd algorithm -* - IF( .NOT.ROTATE ) THEN - CALL DLASQ1( N, D, E, WORK, INFO ) - RETURN - END IF -* - NM1 = N - 1 - NM12 = NM1 + NM1 - NM13 = NM12 + NM1 -* -* Get machine constants -* - EPS = DLAMCH( 'Epsilon' ) - UNFL = DLAMCH( 'Safe minimum' ) -* -* If matrix lower bidiagonal, rotate to be upper bidiagonal -* by applying Givens rotations on the left -* - IF( IUPLO.EQ.2 ) THEN - DO 10 I = 1, N - 1 - CALL DLARTG( D( I ), E( I ), CS, SN, R ) - D( I ) = R - E( I ) = SN*D( I+1 ) - D( I+1 ) = CS*D( I+1 ) - WORK( I ) = CS - WORK( NM1+I ) = SN - 10 CONTINUE -* -* Update singular vectors if desired -* - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, - $ LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, - $ LDC ) - END IF -* -* Compute singular values to relative accuracy TOL -* (By setting TOL to be negative, algorithm will compute -* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) -* - TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) - TOL = TOLMUL*EPS -* -* Compute approximate maximum, minimum singular values -* - SMAX = ABS( D( N ) ) - DO 20 I = 1, N - 1 - SMAX = MAX( SMAX, ABS( D( I ) ), ABS( E( I ) ) ) - 20 CONTINUE - SMINL = ZERO - IF( TOL.GE.ZERO ) THEN -* -* Relative accuracy desired -* - SMINOA = ABS( D( 1 ) ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 40 - MU = SMINOA - DO 30 I = 2, N - MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) - SMINOA = MIN( SMINOA, MU ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 40 - 30 CONTINUE - 40 CONTINUE - SMINOA = SMINOA / SQRT( DBLE( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) - ELSE -* -* Absolute accuracy desired -* - THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) - END IF -* -* Prepare for main iteration loop for the singular values -* (MAXIT is the maximum number of passes through the inner -* loop permitted before nonconvergence signalled.) -* - MAXIT = MAXITR*N*N - ITER = 0 - OLDLL = -1 - OLDM = -1 -* -* M points to last element of unconverged part of matrix -* - M = N -* -* Begin main iteration loop -* - 50 CONTINUE -* -* Check for convergence or exceeding iteration count -* - IF( M.LE.1 ) - $ GO TO 150 - IF( ITER.GT.MAXIT ) - $ GO TO 190 -* -* Find diagonal block of matrix to work on -* - IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) - $ D( M ) = ZERO - SMAX = ABS( D( M ) ) - SMIN = SMAX - DO 60 LLL = 1, M - LL = M - LLL - IF( LL.EQ.0 ) - $ GO TO 80 - ABSS = ABS( D( LL ) ) - ABSE = ABS( E( LL ) ) - IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) - $ D( LL ) = ZERO - IF( ABSE.LE.THRESH ) - $ GO TO 70 - SMIN = MIN( SMIN, ABSS ) - SMAX = MAX( SMAX, ABSS, ABSE ) - 60 CONTINUE - 70 CONTINUE - E( LL ) = ZERO -* -* Matrix splits since E(LL) = 0 -* - IF( LL.EQ.M-1 ) THEN -* -* Convergence of bottom singular value, return to top of loop -* - M = M - 1 - GO TO 50 - END IF - 80 CONTINUE - LL = LL + 1 -* -* E(LL) through E(M-1) are nonzero, E(LL-1) is zero -* - IF( LL.EQ.M-1 ) THEN -* -* 2 by 2 block, handle separately -* - CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, - $ COSR, SINL, COSL ) - D( M-1 ) = SIGMX - E( M-1 ) = ZERO - D( M ) = SIGMN -* -* Compute singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, - $ SINR ) - IF( NRU.GT.0 ) - $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) - IF( NCC.GT.0 ) - $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, - $ SINL ) - M = M - 2 - GO TO 50 - END IF -* -* If working on new submatrix, choose shift direction -* (from larger end diagonal element towards smaller) -* - IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN - IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN -* -* Chase bulge from top (big end) to bottom (small end) -* - IDIR = 1 - ELSE -* -* Chase bulge from bottom (big end) to top (small end) -* - IDIR = 2 - END IF - END IF -* -* Apply convergence tests -* - IF( IDIR.EQ.1 ) THEN -* -* Run convergence test in forward direction -* First apply standard test to bottom of matrix -* - IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN - E( M-1 ) = ZERO - GO TO 50 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion forward -* - MU = ABS( D( LL ) ) - SMINL = MU - DO 90 LLL = LL, M - 1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 50 - END IF - SMINLO = SMINL - MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 90 CONTINUE - END IF -* - ELSE -* -* Run convergence test in backward direction -* First apply standard test to top of matrix -* - IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN - E( LL ) = ZERO - GO TO 50 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion backward -* - MU = ABS( D( M ) ) - SMINL = MU - DO 100 LLL = M - 1, LL, -1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 50 - END IF - SMINLO = SMINL - MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 100 CONTINUE - END IF - END IF - OLDLL = LL - OLDM = M -* -* Compute shift. First, test if shifting would ruin relative -* accuracy, and if so set the shift to zero. -* - IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. - $ MAX( EPS, HNDRTH*TOL ) ) THEN -* -* Use a zero shift to avoid loss of relative accuracy -* - SHIFT = ZERO - ELSE -* -* Compute the shift from 2-by-2 block at end of matrix -* - IF( IDIR.EQ.1 ) THEN - SLL = ABS( D( LL ) ) - CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) - ELSE - SLL = ABS( D( M ) ) - CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) - END IF -* -* Test if shift negligible, and if so set to zero -* - IF( SLL.GT.ZERO ) THEN - IF( ( SHIFT / SLL )**2.LT.EPS ) - $ SHIFT = ZERO - END IF - END IF -* -* Increment iteration count -* - ITER = ITER + M - LL -* -* If SHIFT = 0, do simplified QR iteration -* - IF( SHIFT.EQ.ZERO ) THEN - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - CALL DLARTG( D( LL )*CS, E( LL ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( LL+1 )*SN, OLDCS, OLDSN, D( LL ) ) - WORK( 1 ) = CS - WORK( 1+NM1 ) = SN - WORK( 1+NM12 ) = OLDCS - WORK( 1+NM13 ) = OLDSN - IROT = 1 - DO 110 I = LL + 1, M - 1 - CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - E( I-1 ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT + 1 - WORK( IROT ) = CS - WORK( IROT+NM1 ) = SN - WORK( IROT+NM12 ) = OLDCS - WORK( IROT+NM13 ) = OLDSN - 110 CONTINUE - H = D( M )*CS - D( M ) = H*OLDCS - E( M-1 ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - CALL DLARTG( D( M )*CS, E( M-1 ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( M-1 )*SN, OLDCS, OLDSN, D( M ) ) - WORK( M-LL ) = CS - WORK( M-LL+NM1 ) = -SN - WORK( M-LL+NM12 ) = OLDCS - WORK( M-LL+NM13 ) = -OLDSN - IROT = M - LL - DO 120 I = M - 1, LL + 1, -1 - CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - E( I ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT - 1 - WORK( IROT ) = CS - WORK( IROT+NM1 ) = -SN - WORK( IROT+NM12 ) = OLDCS - WORK( IROT+NM13 ) = -OLDSN - 120 CONTINUE - H = D( LL )*CS - D( LL ) = H*OLDCS - E( LL ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO - END IF - ELSE -* -* Use nonzero shift -* - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( LL ) )-SHIFT )* - $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) - G = E( LL ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( LL ) + SINR*E( LL ) - E( LL ) = COSR*E( LL ) - SINR*D( LL ) - G = SINR*D( LL+1 ) - D( LL+1 ) = COSR*D( LL+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( LL ) = R - F = COSL*E( LL ) + SINL*D( LL+1 ) - D( LL+1 ) = COSL*D( LL+1 ) - SINL*E( LL ) - G = SINL*E( LL+1 ) - E( LL+1 ) = COSL*E( LL+1 ) - WORK( 1 ) = COSR - WORK( 1+NM1 ) = SINR - WORK( 1+NM12 ) = COSL - WORK( 1+NM13 ) = SINL - IROT = 1 - DO 130 I = LL + 1, M - 2 - CALL DLARTG( F, G, COSR, SINR, R ) - E( I-1 ) = R - F = COSR*D( I ) + SINR*E( I ) - E( I ) = COSR*E( I ) - SINR*D( I ) - G = SINR*D( I+1 ) - D( I+1 ) = COSR*D( I+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I ) + SINL*D( I+1 ) - D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - IROT = IROT + 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = SINL - 130 CONTINUE - CALL DLARTG( F, G, COSR, SINR, R ) - E( M-2 ) = R - F = COSR*D( M-1 ) + SINR*E( M-1 ) - E( M-1 ) = COSR*E( M-1 ) - SINR*D( M-1 ) - G = SINR*D( M ) - D( M ) = COSR*D( M ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( M-1 ) = R - F = COSL*E( M-1 ) + SINL*D( M ) - D( M ) = COSL*D( M ) - SINL*E( M-1 ) - IROT = IROT + 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = SINL - E( M-1 ) = F -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / - $ D( M ) ) - G = E( M-1 ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( M ) + SINR*E( M-1 ) - E( M-1 ) = COSR*E( M-1 ) - SINR*D( M ) - G = SINR*D( M-1 ) - D( M-1 ) = COSR*D( M-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( M ) = R - F = COSL*E( M-1 ) + SINL*D( M-1 ) - D( M-1 ) = COSL*D( M-1 ) - SINL*E( M-1 ) - G = SINL*E( M-2 ) - E( M-2 ) = COSL*E( M-2 ) - WORK( M-LL ) = COSR - WORK( M-LL+NM1 ) = -SINR - WORK( M-LL+NM12 ) = COSL - WORK( M-LL+NM13 ) = -SINL - IROT = M - LL - DO 140 I = M - 1, LL + 2, -1 - CALL DLARTG( F, G, COSR, SINR, R ) - E( I ) = R - F = COSR*D( I ) + SINR*E( I-1 ) - E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) - G = SINR*D( I-1 ) - D( I-1 ) = COSR*D( I-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I-1 ) + SINL*D( I-1 ) - D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - IROT = IROT - 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = -SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = -SINL - 140 CONTINUE - CALL DLARTG( F, G, COSR, SINR, R ) - E( LL+1 ) = R - F = COSR*D( LL+1 ) + SINR*E( LL ) - E( LL ) = COSR*E( LL ) - SINR*D( LL+1 ) - G = SINR*D( LL ) - D( LL ) = COSR*D( LL ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( LL+1 ) = R - F = COSL*E( LL ) + SINL*D( LL ) - D( LL ) = COSL*D( LL ) - SINL*E( LL ) - IROT = IROT - 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = -SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = -SINL - E( LL ) = F -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO -* -* Update singular vectors if desired -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) - END IF - END IF -* -* QR iteration finished, go back and check convergence -* - GO TO 50 -* -* All singular values converged, so make them positive -* - 150 CONTINUE - DO 160 I = 1, N - IF( D( I ).LT.ZERO ) THEN - D( I ) = -D( I ) -* -* Change sign of singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) - END IF - 160 CONTINUE -* -* Sort the singular values into decreasing order (insertion sort on -* singular values, but only one transposition per singular vector) -* - DO 180 I = 1, N - 1 -* -* Scan for smallest D(I) -* - ISUB = 1 - SMIN = D( 1 ) - DO 170 J = 2, N + 1 - I - IF( D( J ).LE.SMIN ) THEN - ISUB = J - SMIN = D( J ) - END IF - 170 CONTINUE - IF( ISUB.NE.N+1-I ) THEN -* -* Swap singular values and vectors -* - D( ISUB ) = D( N+1-I ) - D( N+1-I ) = SMIN - IF( NCVT.GT.0 ) - $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), - $ LDVT ) - IF( NRU.GT.0 ) - $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) - IF( NCC.GT.0 ) - $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) - END IF - 180 CONTINUE - GO TO 210 -* -* Maximum number of iterations exceeded, failure to converge -* - 190 CONTINUE - INFO = 0 - DO 200 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 200 CONTINUE - 210 CONTINUE - RETURN -* -* End of DBDSQR -* - END diff --git a/Cantera/ext/lapack/dgbsv.f b/Cantera/ext/lapack/dgbsv.f deleted file mode 100755 index e2d8b5ebd..000000000 --- a/Cantera/ext/lapack/dgbsv.f +++ /dev/null @@ -1,144 +0,0 @@ - SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGBSV computes the solution to a real system of linear equations -* A * X = B, where A is a band matrix of order N with KL subdiagonals -* and KU superdiagonals, and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as A = L * U, where L is a product of permutation -* and unit lower triangular matrices with KL subdiagonals, and U is -* upper triangular with KL+KU superdiagonals. The factored form of A -* is then used to solve the system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* 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/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(N,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 (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and the solution has not been computed. -* -* 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. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DGBTRF, DGBTRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( KL.LT.0 ) THEN - INFO = -2 - ELSE IF( KU.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBSV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of the band matrix A. -* - CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV, - $ B, LDB, INFO ) - END IF - RETURN -* -* End of DGBSV -* - END diff --git a/Cantera/ext/lapack/dgbtf2.f b/Cantera/ext/lapack/dgbtf2.f deleted file mode 100755 index 5e25629fc..000000000 --- a/Cantera/ext/lapack/dgbtf2.f +++ /dev/null @@ -1,203 +0,0 @@ - SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - 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 diff --git a/Cantera/ext/lapack/dgbtrf.f b/Cantera/ext/lapack/dgbtrf.f deleted file mode 100755 index c6e3d0a9c..000000000 --- a/Cantera/ext/lapack/dgbtrf.f +++ /dev/null @@ -1,442 +0,0 @@ - SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - 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 diff --git a/Cantera/ext/lapack/dgbtrs.f b/Cantera/ext/lapack/dgbtrs.f deleted file mode 100755 index 26fdf91eb..000000000 --- a/Cantera/ext/lapack/dgbtrs.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, 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 diff --git a/Cantera/ext/lapack/dgebd2.f b/Cantera/ext/lapack/dgebd2.f deleted file mode 100755 index 0bdac2d24..000000000 --- a/Cantera/ext/lapack/dgebd2.f +++ /dev/null @@ -1,238 +0,0 @@ - SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, 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, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEBD2 reduces a real general m by n matrix A to upper or lower -* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. -* -* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns in the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n general matrix to be reduced. -* On exit, -* if m >= n, the diagonal and the first superdiagonal are -* overwritten with the upper bidiagonal matrix B; the -* elements below the diagonal, with the array TAUQ, represent -* the orthogonal matrix Q as a product of elementary -* reflectors, and the elements above the first superdiagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors; -* if m < n, the diagonal and the first subdiagonal are -* overwritten with the lower bidiagonal matrix B; the -* elements below the first subdiagonal, with the array TAUQ, -* represent the orthogonal matrix Q as a product of -* elementary reflectors, and the elements above the diagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The diagonal elements of the bidiagonal matrix B: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) -* The off-diagonal elements of the bidiagonal matrix B: -* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -* -* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* If m >= n, -* -* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, -* -* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The contents of A on exit are illustrated by the following examples: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -* ( v1 v2 v3 v4 v5 ) -* -* where d and e denote diagonal and off-diagonal elements of B, vi -* denotes an element of the vector defining H(i), and ui an element of -* the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBD2', -INFO ) - RETURN - END IF -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, N -* -* 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, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.N ) THEN -* -* Generate elementary reflector G(i) to annihilate -* A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Apply G(i) to A(i+1:m,i+1:n) from the right -* - CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) - A( I, I+1 ) = E( I ) - ELSE - TAUP( I ) = ZERO - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, M -* -* Generate elementary reflector G(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply G(i) to A(i+1:m,i:n) from the right -* - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.M ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Apply H(i) to A(i+1:m,i+1:n) from the left -* - CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), - $ A( I+1, I+1 ), LDA, WORK ) - A( I+1, I ) = E( I ) - ELSE - TAUQ( I ) = ZERO - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGEBD2 -* - END diff --git a/Cantera/ext/lapack/dgebrd.f b/Cantera/ext/lapack/dgebrd.f deleted file mode 100755 index 5ccaed3f5..000000000 --- a/Cantera/ext/lapack/dgebrd.f +++ /dev/null @@ -1,258 +0,0 @@ - SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DGEBRD reduces a general real M-by-N matrix A to upper or lower -* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. -* -* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns in the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N general matrix to be reduced. -* On exit, -* if m >= n, the diagonal and the first superdiagonal are -* overwritten with the upper bidiagonal matrix B; the -* elements below the diagonal, with the array TAUQ, represent -* the orthogonal matrix Q as a product of elementary -* reflectors, and the elements above the first superdiagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors; -* if m < n, the diagonal and the first subdiagonal are -* overwritten with the lower bidiagonal matrix B; the -* elements below the first subdiagonal, with the array TAUQ, -* represent the orthogonal matrix Q as a product of -* elementary reflectors, and the elements above the diagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The diagonal elements of the bidiagonal matrix B: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) -* The off-diagonal elements of the bidiagonal matrix B: -* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -* -* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,M,N). -* For optimum performance LWORK >= (M+N)*NB, where NB -* is the optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* If m >= n, -* -* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, -* -* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The contents of A on exit are illustrated by the following examples: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -* ( v1 v2 v3 v4 v5 ) -* -* where d and e denote diagonal and off-diagonal elements of B, vi -* denotes an element of the vector defining H(i), and ui an element of -* the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, LDWRKX, LDWRKY, MINMN, NB, NBMIN, - $ NX - DOUBLE PRECISION WS -* .. -* .. External Subroutines .. - EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M, N ) ) THEN - INFO = -10 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBRD', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - WS = MAX( M, N ) - LDWRKX = M - LDWRKY = N -* -* Set the block size NB and the crossover point NX. -* - NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) -* - IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN -* -* Determine when to switch from blocked to unblocked code. -* - NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) - IF( NX.LT.MINMN ) THEN - WS = ( M+N )*NB - IF( LWORK.LT.WS ) THEN -* -* Not enough work space for the optimal NB, consider using -* a smaller block size. -* - NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) - IF( LWORK.GE.( M+N )*NBMIN ) THEN - NB = LWORK / ( M+N ) - ELSE - NB = 1 - NX = MINMN - END IF - END IF - END IF - ELSE - NX = MINMN - END IF -* - DO 30 I = 1, MINMN - NX, NB -* -* Reduce rows and columns i:i+nb-1 to bidiagonal form and return -* the matrices X and Y which are needed to update the unreduced -* part of the matrix -* - CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, - $ WORK( LDWRKX*NB+1 ), LDWRKY ) -* -* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update -* of the form A := A - V*Y' - X*U' -* - CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, A( I+NB, I ), LDA, - $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, - $ A( I+NB, I+NB ), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, - $ ONE, A( I+NB, I+NB ), LDA ) -* -* Copy diagonal and off-diagonal elements of B back into A -* - IF( M.GE.N ) THEN - DO 10 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J, J+1 ) = E( J ) - 10 CONTINUE - ELSE - DO 20 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J+1, J ) = E( J ) - 20 CONTINUE - END IF - 30 CONTINUE -* -* Use unblocked code to reduce the remainder of the matrix -* - CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, IINFO ) - WORK( 1 ) = WS - RETURN -* -* End of DGEBRD -* - END diff --git a/Cantera/ext/lapack/dgelq2.f b/Cantera/ext/lapack/dgelq2.f deleted file mode 100755 index 699a70cfe..000000000 --- a/Cantera/ext/lapack/dgelq2.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE DGELQ2( 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 -* ======= -* -* DGELQ2 computes an LQ factorization of a real m by n matrix A: -* A = L * Q. -* -* 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 below the diagonal of the array -* contain the m by min(m,n) lower trapezoidal matrix L (L is -* lower triangular if m <= n); the elements above 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 (M) -* -* 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(k) . . . H(2) H(1), 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:n) is stored on exit in A(i,i+1:n), -* 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( 'DGELQ2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAU( I ) ) - IF( I.LT.M ) THEN -* -* Apply H(i) to A(i+1:m,i:n) from the right -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), - $ A( I+1, I ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGELQ2 -* - END diff --git a/Cantera/ext/lapack/dgelqf.f b/Cantera/ext/lapack/dgelqf.f deleted file mode 100755 index 0910606a8..000000000 --- a/Cantera/ext/lapack/dgelqf.f +++ /dev/null @@ -1,186 +0,0 @@ - SUBROUTINE DGELQF( M, N, A, LDA, TAU, 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DGELQF computes an LQ factorization of a real M-by-N matrix A: -* A = L * Q. -* -* 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 below the diagonal of the array -* contain the m-by-min(m,n) lower trapezoidal matrix L (L is -* lower triangular if m <= n); the elements above 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/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,M). -* For optimum performance LWORK >= M*NB, where NB is the -* optimal blocksize. -* -* 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(k) . . . H(2) H(1), 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:n) is stored on exit in A(i,i+1:n), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. 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 - ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELQF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the LQ factorization of the current block -* A(i:i+ib-1,i:n) -* - CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'No transpose', 'Forward', - $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), - $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, - $ WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGELQF -* - END diff --git a/Cantera/ext/lapack/dgelss.f b/Cantera/ext/lapack/dgelss.f deleted file mode 100755 index 36c3bb489..000000000 --- a/Cantera/ext/lapack/dgelss.f +++ /dev/null @@ -1,604 +0,0 @@ - SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, - $ WORK, LWORK, INFO ) -* -* -- LAPACK driver 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, LDB, LWORK, M, N, NRHS, RANK - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGELSS computes the minimum norm solution to a real linear least -* squares problem: -* -* Minimize 2-norm(| b - A*x |). -* -* using the singular value decomposition (SVD) of A. A is an M-by-N -* matrix which may be rank-deficient. -* -* Several right hand side vectors b and solution vectors x can be -* handled in a single call; they are stored as the columns of the -* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix -* X. -* -* The effective rank of A is determined by treating as zero those -* singular values which are less than RCOND times the largest singular -* value. -* -* 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. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrices B and X. NRHS >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the first min(m,n) rows of A are overwritten with -* its right singular vectors, stored rowwise. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the M-by-NRHS right hand side matrix B. -* On exit, B is overwritten by the N-by-NRHS solution -* matrix X. If m >= n and RANK = n, the residual -* sum-of-squares for the solution in the i-th column is given -* by the sum of squares of elements n+1:m in that column. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,max(M,N)). -* -* S (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The singular values of A in decreasing order. -* The condition number of A in the 2-norm = S(1)/S(min(m,n)). -* -* RCOND (input) DOUBLE PRECISION -* RCOND is used to determine the effective rank of A. -* Singular values S(i) <= RCOND*S(1) are treated as zero. -* If RCOND < 0, machine precision is used instead. -* -* RANK (output) INTEGER -* The effective rank of A, i.e., the number of singular values -* which are greater than RCOND*S(1). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= 1, and also: -* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) -* For good performance, LWORK should generally be larger. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: the algorithm for computing the SVD failed to converge; -* if INFO = i, i off-diagonal elements of an intermediate -* bidiagonal form did not converge to zero. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, - $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, - $ MAXWRK, MINMN, MINWRK, MM, MNTHR - DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR -* .. -* .. Local Arrays .. - DOUBLE PRECISION VDUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV, - $ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR, - $ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL ILAENV, DLAMCH, DLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - MINMN = MIN( M, N ) - MAXMN = MAX( M, N ) - MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN - INFO = -7 - END IF -* -* Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV.) -* - MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN - MAXWRK = 0 - MM = M - IF( M.GE.N .AND. M.GE.MNTHR ) THEN -* -* Path 1a - overdetermined, with many more rows than columns -* - MM = N - MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, - $ -1, -1 ) ) - MAXWRK = MAX( MAXWRK, N+NRHS* - $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) ) - END IF - IF( M.GE.N ) THEN -* -* Path 1 - overdetermined or exactly determined -* -* Compute workspace neede for DBDSQR -* - BDSPAC = MAX( 1, 5*N-4 ) - MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* - $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*N+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - MINWRK = MAX( 3*N+MM, 3*N+NRHS, BDSPAC ) - MAXWRK = MAX( MINWRK, MAXWRK ) - - END IF - IF( N.GT.M ) THEN -* -* Compute workspace neede for DBDSQR -* - BDSPAC = MAX( 1, 5*M-4 ) - MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) - IF( N.GE.MNTHR ) THEN -* -* Path 2a - underdetermined, with many more columns -* than rows -* - MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+M+BDSPAC ) - IF( NRHS.GT.1 ) THEN - MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) - ELSE - MAXWRK = MAX( MAXWRK, M*M+2*M ) - END IF - MAXWRK = MAX( MAXWRK, M+NRHS* - $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) - ELSE -* -* Path 2 - underdetermined -* - MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, - $ -1, -1 ) - MAXWRK = MAX( MAXWRK, 3*M+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - END IF - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) - WORK( 1 ) = MAXWRK - END IF -* - MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK ) - $ INFO = -12 - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELSS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RANK = 0 - RETURN - END IF -* -* Get machine parameters -* - EPS = DLAMCH( 'P' ) - SFMIN = DLAMCH( 'S' ) - SMLNUM = SFMIN / EPS - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM -* - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM -* - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -* -* Matrix all zero. Return zero solution. -* - CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) - CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 ) - RANK = 0 - GO TO 70 - END IF -* -* Scale B if max element outside range [SMLNUM,BIGNUM] -* - BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM -* - CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM -* - CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) - IBSCL = 2 - END IF -* -* Overdetermined case -* - IF( M.GE.N ) THEN -* -* Path 1 - overdetermined or exactly determined -* - MM = M - IF( M.GE.MNTHR ) THEN -* -* Path 1a - overdetermined, with many more rows than columns -* - MM = N - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Multiply B by transpose(Q) -* (Workspace: need N+NRHS, prefer N+NRHS*NB) -* - CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, - $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Zero out below R -* - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) - END IF -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in A -* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) -* - CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors of R -* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), - $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors of R in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration -* multiply B by transpose of left singular vectors -* compute right singular vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM, - $ 1, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 10 I = 1, N - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 10 CONTINUE -* -* Multiply B by right singular vectors -* (Workspace: need N, prefer N*NRHS) -* - IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO, - $ WORK, LDB ) - CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = LWORK / N - DO 20 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B, LDB, - $ ZERO, WORK, N ) - CALL DLACPY( 'G', N, BL, WORK, N, B, LDB ) - 20 CONTINUE - ELSE - CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) - CALL DCOPY( N, WORK, 1, B, 1 ) - END IF -* - ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ - $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN -* -* Path 2a - underdetermined, with many more columns than rows -* and sufficient workspace for an efficient algorithm -* - LDWORK = M - IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), - $ M*LDA+M+M*NRHS ) )LDWORK = LDA - ITAU = 1 - IWORK = M + 1 -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) - IL = IWORK -* -* Copy L to WORK(IL), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), - $ LDWORK ) - IE = IL + LDWORK*M - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IL) -* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors of L -* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, - $ WORK( ITAUQ ), B, LDB, WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors of R in WORK(IL) -* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, -* computing right singular vectors of L in WORK(IL) and -* multiplying B by transpose of left singular vectors -* (Workspace: need M*M+M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ), - $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 30 I = 1, M - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 30 CONTINUE - IWORK = IE -* -* Multiply B by right singular vectors of L in WORK(IL) -* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) -* - IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK, - $ B, LDB, ZERO, WORK( IWORK ), LDB ) - CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = ( LWORK-IWORK+1 ) / M - DO 40 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, ZERO, WORK( IWORK ), N ) - CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B, LDB ) - 40 CONTINUE - ELSE - CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ), - $ 1, ZERO, WORK( IWORK ), 1 ) - CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 ) - END IF -* -* Zero out below first M rows of B -* - CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) - IWORK = ITAU + M -* -* Multiply transpose(Q) by B -* (Workspace: need M+NRHS, prefer M+NRHS*NB) -* - CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, - $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* - ELSE -* -* Path 2 - remaining underdetermined cases -* - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors -* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), - $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, -* computing right singular vectors of A in A and -* multiplying B by transpose of left singular vectors -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM, - $ 1, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 50 I = 1, M - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 50 CONTINUE -* -* Multiply B by right singular vectors of A -* (Workspace: need N, prefer N*NRHS) -* - IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO, - $ WORK, LDB ) - CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = LWORK / N - DO 60 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ), - $ LDB, ZERO, WORK, N ) - CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB ) - 60 CONTINUE - ELSE - CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) - CALL DCOPY( N, WORK, 1, B, 1 ) - END IF - END IF -* -* Undo scaling -* - IF( IASCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) - CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, - $ INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) - CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, - $ INFO ) - END IF - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) - END IF -* - 70 CONTINUE - WORK( 1 ) = MAXWRK - RETURN -* -* End of DGELSS -* - END diff --git a/Cantera/ext/lapack/dgeqr2.f b/Cantera/ext/lapack/dgeqr2.f deleted file mode 100755 index 9dc6435c5..000000000 --- a/Cantera/ext/lapack/dgeqr2.f +++ /dev/null @@ -1,122 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dgeqrf.f b/Cantera/ext/lapack/dgeqrf.f deleted file mode 100755 index 90aeae8ad..000000000 --- a/Cantera/ext/lapack/dgeqrf.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DGEQRF 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 min(m,n) 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/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is -* the optimal blocksize. -* -* 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). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. 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 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H' to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END diff --git a/Cantera/ext/lapack/dgetf2.f b/Cantera/ext/lapack/dgetf2.f deleted file mode 100755 index 27610c487..000000000 --- a/Cantera/ext/lapack/dgetf2.f +++ /dev/null @@ -1,135 +0,0 @@ - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK 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 .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END diff --git a/Cantera/ext/lapack/dgetrf.f b/Cantera/ext/lapack/dgetrf.f deleted file mode 100755 index 7c7fbf22c..000000000 --- a/Cantera/ext/lapack/dgetrf.f +++ /dev/null @@ -1,160 +0,0 @@ - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, 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, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END diff --git a/Cantera/ext/lapack/dgetri.f b/Cantera/ext/lapack/dgetri.f deleted file mode 100755 index efe21b7a0..000000000 --- a/Cantera/ext/lapack/dgetri.f +++ /dev/null @@ -1,801 +0,0 @@ - SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGETRI computes the inverse of a matrix using the LU factorization -* computed by DGETRF. -* -* This method inverts U and then computes inv(A) by solving the system -* inv(A)*L = inv(U) for inv(A). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the factors L and U from the factorization -* A = P*L*U as computed by DGETRF. -* On exit, if INFO = 0, the inverse of the original matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimal performance LWORK >= N*NB, where NB is -* the optimal blocksize returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* 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 matrix is -* singular and its inverse could not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, - $ NBMIN, NN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRI', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, -* and the inverse is not computed. -* - CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = MAX( LDWORK*NB, 1 ) - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) - END IF - ELSE - IWS = N - END IF -* -* Solve the equation inv(A)*L = inv(U) for inv(A). -* - IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - DO 20 J = N, 1, -1 -* -* Copy current column of L to WORK and replace with zeros. -* - DO 10 I = J + 1, N - WORK( I ) = A( I, J ) - A( I, J ) = ZERO - 10 CONTINUE -* -* Compute current column of inv(A). -* - IF( J.LT.N ) - $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), - $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) - 20 CONTINUE - ELSE -* -* Use blocked code. -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 50 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) -* -* Copy current block column of L to WORK and replace with -* zeros. -* - DO 40 JJ = J, J + JB - 1 - DO 30 I = JJ + 1, N - WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) - A( I, JJ ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Compute current block column of inv(A). -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, - $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, - $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, - $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) - 50 CONTINUE - END IF -* -* Apply column interchanges. -* - DO 60 J = N - 1, 1, -1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 60 CONTINUE -* - WORK( 1 ) = IWS - RETURN -* -* End of DGETRI -* - END - SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTI2 computes the inverse of a real upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DTRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DTRTI2 -* - END - SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTRI computes the inverse of a real upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of DTRTRI -* - END - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1998 -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) REAL -* Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* RETURN VALUE: INTEGER -* = 0: Arithmetic failed to produce the correct answers -* = 1: Arithmetic produced the correct answers -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*0.0 -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END - -c END - -c LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. -c 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 .. -c INTRINSIC ICHAR -* .. -* .. Local Scalars .. -c INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* Test if the characters are equal -* -c LSAME = CA.EQ.CB -c IF( LSAME ) -c $ RETURN -* -* Now test for equivalence if both characters are alphabetic. -* -c 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. -* -c INTA = ICHAR( CA ) -c INTB = ICHAR( CB ) -* -c IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* -c IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 -c IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* -c 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'. -* -c IF( INTA.GE.129 .AND. INTA.LE.137 .OR. -c $ INTA.GE.145 .AND. INTA.LE.153 .OR. -c $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 -c IF( INTB.GE.129 .AND. INTB.LE.137 .OR. -c $ INTB.GE.145 .AND. INTB.LE.153 .OR. -c $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 -* -c 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'. -* -c IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 -c IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 -c END IF -c LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* -c END -c$$$ SUBROUTINE XERBLA( SRNAME, INFO ) -c$$$* -c$$$* -- LAPACK auxiliary routine (version 3.0) -- -c$$$* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -c$$$* Courant Institute, Argonne National Lab, and Rice University -c$$$* September 30, 1994 -c$$$* -c$$$* .. Scalar Arguments .. -c$$$ CHARACTER*6 SRNAME -c$$$ INTEGER INFO -c$$$* .. -c$$$* -c$$$* Purpose -c$$$* ======= -c$$$* -c$$$* XERBLA is an error handler for the LAPACK routines. -c$$$* It is called by an LAPACK routine if an input parameter has an -c$$$* invalid value. A message is printed and execution stops. -c$$$* -c$$$* Installers may consider modifying the STOP statement in order to -c$$$* call system-specific exception-handling facilities. -c$$$* -c$$$* Arguments -c$$$* ========= -c$$$* -c$$$* SRNAME (input) CHARACTER*6 -c$$$* The name of the routine which called XERBLA. -c$$$* -c$$$* INFO (input) INTEGER -c$$$* The position of the invalid parameter in the parameter list -c$$$* of the calling routine. -c$$$* -c$$$* ===================================================================== -c$$$* -c$$$* .. Executable Statements .. -c$$$* -c$$$ WRITE( *, FMT = 9999 )SRNAME, INFO -c$$$* -c$$$ STOP -c$$$* -c$$$ 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', -c$$$ $ 'an illegal value' ) -c$$$* -c$$$* End of XERBLA -c$$$* -c$$$ END \ No newline at end of file diff --git a/Cantera/ext/lapack/dgetrs.f b/Cantera/ext/lapack/dgetrs.f deleted file mode 100755 index 1d0db1e91..000000000 --- a/Cantera/ext/lapack/dgetrs.f +++ /dev/null @@ -1,150 +0,0 @@ - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, 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, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A' * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END diff --git a/Cantera/ext/lapack/dlabad.f b/Cantera/ext/lapack/dlabad.f deleted file mode 100755 index 1f453d222..000000000 --- a/Cantera/ext/lapack/dlabad.f +++ /dev/null @@ -1,56 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlabrd.f b/Cantera/ext/lapack/dlabrd.f deleted file mode 100755 index 50d333af4..000000000 --- a/Cantera/ext/lapack/dlabrd.f +++ /dev/null @@ -1,291 +0,0 @@ - SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, - $ LDY ) -* -* -- 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 LDA, LDX, LDY, M, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) -* .. -* -* Purpose -* ======= -* -* DLABRD reduces the first NB rows and columns of a real general -* m by n matrix A to upper or lower bidiagonal form by an orthogonal -* transformation Q' * A * P, and returns the matrices X and Y which -* are needed to apply the transformation to the unreduced part of A. -* -* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower -* bidiagonal form. -* -* This is an auxiliary routine called by DGEBRD -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. -* -* N (input) INTEGER -* The number of columns in the matrix A. -* -* NB (input) INTEGER -* The number of leading rows and columns of A to be reduced. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n general matrix to be reduced. -* On exit, the first NB rows and columns of the matrix are -* overwritten; the rest of the array is unchanged. -* If m >= n, elements on and below the diagonal in the first NB -* columns, with the array TAUQ, represent the orthogonal -* matrix Q as a product of elementary reflectors; and -* elements above the diagonal in the first NB rows, with the -* array TAUP, represent the orthogonal matrix P as a product -* of elementary reflectors. -* If m < n, elements below the diagonal in the first NB -* columns, with the array TAUQ, represent the orthogonal -* matrix Q as a product of elementary reflectors, and -* elements on and above the diagonal in the first NB rows, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (NB) -* The diagonal elements of the first NB rows and columns of -* the reduced matrix. D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (NB) -* The off-diagonal elements of the first NB rows and columns of -* the reduced matrix. -* -* TAUQ (output) DOUBLE PRECISION array dimension (NB) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (NB) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* X (output) DOUBLE PRECISION array, dimension (LDX,NB) -* The m-by-nb matrix X required to update the unreduced part -* of A. -* -* LDX (input) INTEGER -* The leading dimension of the array X. LDX >= M. -* -* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) -* The n-by-nb matrix Y required to update the unreduced part -* of A. -* -* LDY (output) INTEGER -* The leading dimension of the array Y. LDY >= N. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors. -* -* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in -* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in -* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The elements of the vectors v and u together form the m-by-nb matrix -* V and the nb-by-n matrix U' which are needed, with X and Y, to apply -* the transformation to the unreduced part of the matrix, using a block -* update of the form: A := A - V*Y' - X*U'. -* -* The contents of A on exit are illustrated by the following examples -* with nb = 2: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) -* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) -* ( v1 v2 a a a ) ( v1 1 a a a a ) -* ( v1 v2 a a a ) ( v1 v2 a a a a ) -* ( v1 v2 a a a ) ( v1 v2 a a a a ) -* ( v1 v2 a a a ) -* -* where a denotes an element of the original matrix which is unchanged, -* vi denotes an element of the vector defining H(i), and ui an element -* of the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DLARFG, DSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, NB -* -* Update A(i:m,i) -* - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), - $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) -* -* Update A(i,i+1:n) -* - CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, - $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, NB -* -* Update A(i,i:n) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, - $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - IF( I.LT.M ) THEN - A( I, I ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, - $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) -* -* Update A(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, - $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DLABRD -* - END diff --git a/Cantera/ext/lapack/dlacpy.f b/Cantera/ext/lapack/dlacpy.f deleted file mode 100755 index 6820d45fb..000000000 --- a/Cantera/ext/lapack/dlacpy.f +++ /dev/null @@ -1,88 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlamch.f b/Cantera/ext/lapack/dlamch.f deleted file mode 100755 index e293aa8c7..000000000 --- a/Cantera/ext/lapack/dlamch.f +++ /dev/null @@ -1,857 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlange.f b/Cantera/ext/lapack/dlange.f deleted file mode 100755 index 0737f03ea..000000000 --- a/Cantera/ext/lapack/dlange.f +++ /dev/null @@ -1,145 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlapy2.f b/Cantera/ext/lapack/dlapy2.f deleted file mode 100755 index d38196132..000000000 --- a/Cantera/ext/lapack/dlapy2.f +++ /dev/null @@ -1,54 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlarf.f b/Cantera/ext/lapack/dlarf.f deleted file mode 100755 index 1bb357f9b..000000000 --- a/Cantera/ext/lapack/dlarf.f +++ /dev/null @@ -1,116 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlarfb.f b/Cantera/ext/lapack/dlarfb.f deleted file mode 100755 index 4e4f18600..000000000 --- a/Cantera/ext/lapack/dlarfb.f +++ /dev/null @@ -1,588 +0,0 @@ - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- 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 DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* Purpose -* ======= -* -* DLARFB applies a real block reflector H or its transpose H' to a -* real m by n matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H' from the Left -* = 'R': apply H or H' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'T': apply H' (Transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) DOUBLE PRECISION array, dimension (LDT,K) -* The triangular k by k matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDA >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C1' -* - DO 10 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W' -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2' -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C2' -* - DO 70 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W' -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 90 J = 1, K - DO 80 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1' -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C1' -* - DO 130 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2' -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, - $ WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2' * W' -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2' -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C2' -* - DO 190 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1' -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1' * W' -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 210 J = 1, K - DO 200 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1' -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END diff --git a/Cantera/ext/lapack/dlarfg.f b/Cantera/ext/lapack/dlarfg.f deleted file mode 100755 index a8e64c1b9..000000000 --- a/Cantera/ext/lapack/dlarfg.f +++ /dev/null @@ -1,138 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlarft.f b/Cantera/ext/lapack/dlarft.f deleted file mode 100755 index 6035df482..000000000 --- a/Cantera/ext/lapack/dlarft.f +++ /dev/null @@ -1,218 +0,0 @@ - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- 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 DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* DLARFT forms the triangular factor T of a real block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V' -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V' * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) DOUBLE PRECISION array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION VII -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 I = 1, K - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -* -* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) -* - CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, - $ T( 1, I ), 1 ) - ELSE -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' -* - CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - END IF - 20 CONTINUE - ELSE - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, - $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' -* - CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, - $ T( I+1, I ), 1 ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of DLARFT -* - END diff --git a/Cantera/ext/lapack/dlartg.f b/Cantera/ext/lapack/dlartg.f deleted file mode 100755 index 502f13eeb..000000000 --- a/Cantera/ext/lapack/dlartg.f +++ /dev/null @@ -1,143 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlas2.f b/Cantera/ext/lapack/dlas2.f deleted file mode 100755 index ad2f337dc..000000000 --- a/Cantera/ext/lapack/dlas2.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* -* -- 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 F, G, H, SSMAX, SSMIN -* .. -* -* Purpose -* ======= -* -* DLAS2 computes the singular values of the 2-by-2 matrix -* [ F G ] -* [ 0 H ]. -* On return, SSMIN is the smaller singular value and SSMAX is the -* larger singular value. -* -* Arguments -* ========= -* -* F (input) DOUBLE PRECISION -* The (1,1) element of the 2-by-2 matrix. -* -* G (input) DOUBLE PRECISION -* The (1,2) element of the 2-by-2 matrix. -* -* H (input) DOUBLE PRECISION -* The (2,2) element of the 2-by-2 matrix. -* -* SSMIN (output) DOUBLE PRECISION -* The smaller singular value. -* -* SSMAX (output) DOUBLE PRECISION -* The larger singular value. -* -* Further Details -* =============== -* -* Barring over/underflow, all output quantities are correct to within -* a few units in the last place (ulps), even in the absence of a guard -* digit in addition/subtraction. -* -* In IEEE arithmetic, the code works correctly if one matrix element is -* infinite. -* -* Overflow will not occur unless the largest singular value itself -* overflows, or is within a few ulps of overflow. (On machines with -* partial overflow, like the Cray, overflow may occur if the largest -* singular value is within a factor of 2 of overflow.) -* -* Underflow is harmless if underflow is gradual. Otherwise, results -* may correspond to a matrix modified by perturbations of size near -* the underflow threshold. -* -* ==================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - FA = ABS( F ) - GA = ABS( G ) - HA = ABS( H ) - FHMN = MIN( FA, HA ) - FHMX = MAX( FA, HA ) - IF( FHMN.EQ.ZERO ) THEN - SSMIN = ZERO - IF( FHMX.EQ.ZERO ) THEN - SSMAX = GA - ELSE - SSMAX = MAX( FHMX, GA )*SQRT( ONE+ - $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) - END IF - ELSE - IF( GA.LT.FHMX ) THEN - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - AU = ( GA / FHMX )**2 - C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) - SSMIN = FHMN*C - SSMAX = FHMX / C - ELSE - AU = FHMX / GA - IF( AU.EQ.ZERO ) THEN -* -* Avoid possible harmful underflow if exponent range -* asymmetric (true SSMIN may not underflow even if -* AU underflows) -* - SSMIN = ( FHMN*FHMX ) / GA - SSMAX = GA - ELSE - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ - $ SQRT( ONE+( AT*AU )**2 ) ) - SSMIN = ( FHMN*C )*AU - SSMIN = SSMIN + SSMIN - SSMAX = GA / ( C+C ) - END IF - END IF - END IF - RETURN -* -* End of DLAS2 -* - END diff --git a/Cantera/ext/lapack/dlascl.f b/Cantera/ext/lapack/dlascl.f deleted file mode 100755 index a4d53852e..000000000 --- a/Cantera/ext/lapack/dlascl.f +++ /dev/null @@ -1,268 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlaset.f b/Cantera/ext/lapack/dlaset.f deleted file mode 100755 index c086b6159..000000000 --- a/Cantera/ext/lapack/dlaset.f +++ /dev/null @@ -1,115 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlasq1.f b/Cantera/ext/lapack/dlasq1.f deleted file mode 100755 index 5614aabc7..000000000 --- a/Cantera/ext/lapack/dlasq1.f +++ /dev/null @@ -1,222 +0,0 @@ - SUBROUTINE DLASQ1( N, D, E, 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, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ1 computes the singular values of a real N-by-N bidiagonal -* matrix with diagonal D and off-diagonal E. The singular values are -* computed to high relative accuracy, barring over/underflow or -* denormalization. The algorithm is described in -* -* "Accurate singular values and differential qd algorithms," by -* K. V. Fernando and B. N. Parlett, -* Numer. Math., Vol-67, No. 2, pp. 191-230,1994. -* -* See also -* "Implementation of differential qd algorithms," by -* K. V. Fernando and B. N. Parlett, Technical Report, -* Department of Mathematics, University of California at Berkeley, -* 1994 (Under preparation). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of rows and columns in the matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, D contains the diagonal elements of the -* bidiagonal matrix whose SVD is desired. On normal exit, -* D contains the singular values in decreasing order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, elements E(1:N-1) contain the off-diagonal elements -* of the bidiagonal matrix whose SVD is desired. -* On exit, E is overwritten. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm did not converge; i -* specifies how many superdiagonals did not converge. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HUNDRD - PARAMETER ( HUNDRD = 100.0D0 ) - DOUBLE PRECISION TWO56 - PARAMETER ( TWO56 = 256.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL RESTRT - INTEGER I, IERR, J, KE, KEND, M, NY - DOUBLE PRECISION DM, DX, EPS, SCL, SFMIN, SIG1, SIG2, SIGMN, - $ SIGMX, SMALL2, THRESH, TOL, TOL2, TOLMUL -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -2 - CALL XERBLA( 'DLASQ1', -INFO ) - RETURN - ELSE IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - D( 1 ) = ABS( D( 1 ) ) - RETURN - ELSE IF( N.EQ.2 ) THEN - CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) - D( 1 ) = SIGMX - D( 2 ) = SIGMN - RETURN - END IF -* -* Estimate the largest singular value -* - SIGMX = ZERO - DO 10 I = 1, N - 1 - SIGMX = MAX( SIGMX, ABS( E( I ) ) ) - 10 CONTINUE -* -* Early return if sigmx is zero (matrix is already diagonal) -* - IF( SIGMX.EQ.ZERO ) - $ GO TO 70 -* - DO 20 I = 1, N - D( I ) = ABS( D( I ) ) - SIGMX = MAX( SIGMX, D( I ) ) - 20 CONTINUE -* -* Get machine parameters -* - EPS = DLAMCH( 'EPSILON' ) - SFMIN = DLAMCH( 'SAFE MINIMUM' ) -* -* Compute singular values to relative accuracy TOL -* It is assumed that tol**2 does not underflow. -* - TOLMUL = MAX( TEN, MIN( HUNDRD, EPS**( -MEIGTH ) ) ) - TOL = TOLMUL*EPS - TOL2 = TOL**2 -* - THRESH = SIGMX*SQRT( SFMIN )*TOL -* -* Scale matrix so the square of the largest element is -* 1 / ( 256 * SFMIN ) -* - SCL = SQRT( ONE / ( TWO56*SFMIN ) ) - SMALL2 = ONE / ( TWO56*TOLMUL**2 ) - CALL DCOPY( N, D, 1, WORK( 1 ), 1 ) - CALL DCOPY( N-1, E, 1, WORK( N+1 ), 1 ) - CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N, 1, WORK( 1 ), N, IERR ) - CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N-1, 1, WORK( N+1 ), N-1, - $ IERR ) -* -* Square D and E (the input for the qd algorithm) -* - DO 30 J = 1, 2*N - 1 - WORK( J ) = WORK( J )**2 - 30 CONTINUE -* -* Apply qd algorithm -* - M = 0 - E( N ) = ZERO - DX = WORK( 1 ) - DM = DX - KE = 0 - RESTRT = .FALSE. - DO 60 I = 1, N - IF( ABS( E( I ) ).LE.THRESH .OR. WORK( N+I ).LE.TOL2* - $ ( DM / DBLE( I-M ) ) ) THEN - NY = I - M - IF( NY.EQ.1 ) THEN - GO TO 50 - ELSE IF( NY.EQ.2 ) THEN - CALL DLAS2( D( M+1 ), E( M+1 ), D( M+2 ), SIG1, SIG2 ) - D( M+1 ) = SIG1 - D( M+2 ) = SIG2 - ELSE - KEND = KE + 1 - M - CALL DLASQ2( NY, D( M+1 ), E( M+1 ), WORK( M+1 ), - $ WORK( M+N+1 ), EPS, TOL2, SMALL2, DM, KEND, - $ INFO ) -* -* Return, INFO = number of unconverged superdiagonals -* - IF( INFO.NE.0 ) THEN - INFO = INFO + I - RETURN - END IF -* -* Undo scaling -* - DO 40 J = M + 1, M + NY - D( J ) = SQRT( D( J ) ) - 40 CONTINUE - CALL DLASCL( 'G', 0, 0, SCL, SIGMX, NY, 1, D( M+1 ), NY, - $ IERR ) - END IF - 50 CONTINUE - M = I - IF( I.NE.N ) THEN - DX = WORK( I+1 ) - DM = DX - KE = I - RESTRT = .TRUE. - END IF - END IF - IF( I.NE.N .AND. .NOT.RESTRT ) THEN - DX = WORK( I+1 )*( DX / ( DX+WORK( N+I ) ) ) - IF( DM.GT.DX ) THEN - DM = DX - KE = I - END IF - END IF - RESTRT = .FALSE. - 60 CONTINUE - KEND = KE + 1 -* -* Sort the singular values into decreasing order -* - 70 CONTINUE - CALL DLASRT( 'D', N, D, INFO ) - RETURN -* -* End of DLASQ1 -* - END diff --git a/Cantera/ext/lapack/dlasq2.f b/Cantera/ext/lapack/dlasq2.f deleted file mode 100755 index 14112a673..000000000 --- a/Cantera/ext/lapack/dlasq2.f +++ /dev/null @@ -1,268 +0,0 @@ - SUBROUTINE DLASQ2( M, Q, E, QQ, EE, EPS, TOL2, SMALL2, SUP, KEND, - $ 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, KEND, M - DOUBLE PRECISION EPS, SMALL2, SUP, TOL2 -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ), EE( * ), Q( * ), QQ( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ2 computes the singular values of a real N-by-N unreduced -* bidiagonal matrix with squared diagonal elements in Q and -* squared off-diagonal elements in E. The singular values are -* computed to relative accuracy TOL, barring over/underflow or -* denormalization. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows and columns in the matrix. M >= 0. -* -* Q (output) DOUBLE PRECISION array, dimension (M) -* On normal exit, contains the squared singular values. -* -* E (workspace) DOUBLE PRECISION array, dimension (M) -* -* QQ (input/output) DOUBLE PRECISION array, dimension (M) -* On entry, QQ contains the squared diagonal elements of the -* bidiagonal matrix whose SVD is desired. -* On exit, QQ is overwritten. -* -* EE (input/output) DOUBLE PRECISION array, dimension (M) -* On entry, EE(1:N-1) contains the squared off-diagonal -* elements of the bidiagonal matrix whose SVD is desired. -* On exit, EE is overwritten. -* -* EPS (input) DOUBLE PRECISION -* Machine epsilon. -* -* TOL2 (input) DOUBLE PRECISION -* Desired relative accuracy of computed eigenvalues -* as defined in DLASQ1. -* -* SMALL2 (input) DOUBLE PRECISION -* A threshold value as defined in DLASQ1. -* -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest eigenvalue. -* -* KEND (input/output) INTEGER -* Index where minimum d occurs. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm did not converge; i -* specifies how many superdiagonals did not converge. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION FOUR, HALF - PARAMETER ( FOUR = 4.0D+0, HALF = 0.5D+0 ) -* .. -* .. Local Scalars .. - INTEGER ICONV, IPHASE, ISP, N, OFF, OFF1 - DOUBLE PRECISION QEMAX, SIGMA, XINF, XX, YY -* .. -* .. External Subroutines .. - EXTERNAL DLASQ3 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, NINT, SQRT -* .. -* .. Executable Statements .. - N = M -* -* Set the default maximum number of iterations -* - OFF = 0 - OFF1 = OFF + 1 - SIGMA = ZERO - XINF = ZERO - ICONV = 0 - IPHASE = 2 -* -* Try deflation at the bottom -* -* 1x1 deflation -* - 10 CONTINUE - IF( N.LE.2 ) - $ GO TO 20 - IF( EE( N-1 ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN - Q( N ) = QQ( N ) - N = N - 1 - IF( KEND.GT.N ) - $ KEND = N - SUP = MIN( QQ( N ), QQ( N-1 ) ) - GO TO 10 - END IF -* -* 2x2 deflation -* - IF( EE( N-2 ).LE.MAX( XINF, SMALL2, - $ ( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )*QQ( N-1 ) )* - $ TOL2 ) THEN - QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1 ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) ) - END IF - YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )* - $ MIN( QQ( N ), QQ( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = XX - Q( N ) = YY - N = N - 2 - IF( KEND.GT.N ) - $ KEND = N - SUP = QQ( N ) - GO TO 10 - END IF -* - 20 CONTINUE - IF( N.EQ.0 ) THEN -* -* The lower branch is finished -* - IF( OFF.EQ.0 ) THEN -* -* No upper branch; return to DLASQ1 -* - RETURN - ELSE -* -* Going back to upper branch -* - XINF = ZERO - IF( EE( OFF ).GT.ZERO ) THEN - ISP = NINT( EE( OFF ) ) - IPHASE = 1 - ELSE - ISP = -NINT( EE( OFF ) ) - IPHASE = 2 - END IF - SIGMA = E( OFF ) - N = OFF - ISP + 1 - OFF1 = ISP - OFF = OFF1 - 1 - IF( N.LE.2 ) - $ GO TO 20 - IF( IPHASE.EQ.1 ) THEN - SUP = MIN( Q( N+OFF ), Q( N-1+OFF ), Q( N-2+OFF ) ) - ELSE - SUP = MIN( QQ( N+OFF ), QQ( N-1+OFF ), QQ( N-2+OFF ) ) - END IF - KEND = 0 - ICONV = -3 - END IF - ELSE IF( N.EQ.1 ) THEN -* -* 1x1 Solver -* - IF( IPHASE.EQ.1 ) THEN - Q( OFF1 ) = Q( OFF1 ) + SIGMA - ELSE - Q( OFF1 ) = QQ( OFF1 ) + SIGMA - END IF - N = 0 - GO TO 20 -* -* 2x2 Solver -* - ELSE IF( N.EQ.2 ) THEN - IF( IPHASE.EQ.2 ) THEN - QEMAX = MAX( QQ( N+OFF ), QQ( N-1+OFF ), EE( N-1+OFF ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1+OFF ) ) THEN - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*EE( OFF+N-1 ) / - $ QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N+OFF ) ) THEN - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N-1+OFF )-QQ( N+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*EE( N-1+OFF ) / - $ QEMAX ) ) - ELSE - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*QQ( N-1+OFF ) / - $ QEMAX ) ) - END IF - YY = ( MAX( QQ( N+OFF ), QQ( N-1+OFF ) ) / XX )* - $ MIN( QQ( N+OFF ), QQ( N-1+OFF ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - ELSE - QEMAX = MAX( Q( N+OFF ), Q( N-1+OFF ), E( N-1+OFF ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.Q( N-1+OFF ) ) THEN - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) / - $ QEMAX ) ) - ELSE IF( QEMAX.EQ.Q( N+OFF ) ) THEN - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N-1+OFF )-Q( N+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) / - $ QEMAX ) ) - ELSE - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*Q( N-1+OFF ) / - $ QEMAX ) ) - END IF - YY = ( MAX( Q( N+OFF ), Q( N-1+OFF ) ) / XX )* - $ MIN( Q( N+OFF ), Q( N-1+OFF ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - END IF - Q( N-1+OFF ) = SIGMA + XX - Q( N+OFF ) = YY + SIGMA - N = 0 - GO TO 20 - END IF - CALL DLASQ3( N, Q( OFF1 ), E( OFF1 ), QQ( OFF1 ), EE( OFF1 ), SUP, - $ SIGMA, KEND, OFF, IPHASE, ICONV, EPS, TOL2, SMALL2 ) - IF( SUP.LT.ZERO ) THEN - INFO = N + OFF - RETURN - END IF - OFF1 = OFF + 1 - GO TO 20 -* -* End of DLASQ2 -* - END diff --git a/Cantera/ext/lapack/dlasq3.f b/Cantera/ext/lapack/dlasq3.f deleted file mode 100755 index 03daaaf4c..000000000 --- a/Cantera/ext/lapack/dlasq3.f +++ /dev/null @@ -1,820 +0,0 @@ - SUBROUTINE DLASQ3( N, Q, E, QQ, EE, SUP, SIGMA, KEND, OFF, IPHASE, - $ ICONV, EPS, TOL2, SMALL2 ) -* -* -- 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 ICONV, IPHASE, KEND, N, OFF - DOUBLE PRECISION EPS, SIGMA, SMALL2, SUP, TOL2 -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ), EE( * ), Q( * ), QQ( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ3 is the workhorse of the whole bidiagonal SVD algorithm. -* This can be described as the differential qd with shifts. -* -* Arguments -* ========= -* -* N (input/output) INTEGER -* On entry, N specifies the number of rows and columns -* in the matrix. N must be at least 3. -* On exit N is non-negative and less than the input value. -* -* Q (input/output) DOUBLE PRECISION array, dimension (N) -* Q array in ping (see IPHASE below) -* -* E (input/output) DOUBLE PRECISION array, dimension (N) -* E array in ping (see IPHASE below) -* -* QQ (input/output) DOUBLE PRECISION array, dimension (N) -* Q array in pong (see IPHASE below) -* -* EE (input/output) DOUBLE PRECISION array, dimension (N) -* E array in pong (see IPHASE below) -* -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest eigenvalue -* -* SIGMA (input/output) DOUBLE PRECISION -* Accumulated shift for the present submatrix -* -* KEND (input/output) INTEGER -* Index where minimum D(i) occurs in recurrence for -* splitting criterion -* -* OFF (input/output) INTEGER -* Offset for arrays -* -* IPHASE (input/output) INTEGER -* If IPHASE = 1 (ping) then data is in Q and E arrays -* If IPHASE = 2 (pong) then data is in QQ and EE arrays -* -* ICONV (input) INTEGER -* If ICONV = 0 a bottom part of a matrix (with a split) -* If ICONV =-3 a top part of a matrix (with a split) -* -* EPS (input) DOUBLE PRECISION -* Machine epsilon -* -* TOL2 (input) DOUBLE PRECISION -* Square of the relative tolerance TOL as defined in DLASQ1 -* -* SMALL2 (input) DOUBLE PRECISION -* A threshold value as defined in DLASQ1 -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - INTEGER NPP - PARAMETER ( NPP = 32 ) - INTEGER IPP - PARAMETER ( IPP = 5 ) - DOUBLE PRECISION HALF, FOUR - PARAMETER ( HALF = 0.5D+0, FOUR = 4.0D+0 ) - INTEGER IFLMAX - PARAMETER ( IFLMAX = 2 ) -* .. -* .. Local Scalars .. - LOGICAL LDEF, LSPLIT - INTEGER I, IC, ICNT, IFL, IP, ISP, K1END, K2END, KE, - $ KS, MAXIT, N1, N2 - DOUBLE PRECISION D, DM, QEMAX, T1, TAU, TOLX, TOLY, TOLZ, XX, YY -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLASQ4 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. - ICNT = 0 - TAU = ZERO - DM = SUP - TOLX = SIGMA*TOL2 - TOLZ = MAX( SMALL2, SIGMA )*TOL2 -* -* Set maximum number of iterations -* - MAXIT = 100*N -* -* Flipping -* - IC = 2 - IF( N.GT.3 ) THEN - IF( IPHASE.EQ.1 ) THEN - DO 10 I = 1, N - 2 - IF( Q( I ).GT.Q( I+1 ) ) - $ IC = IC + 1 - IF( E( I ).GT.E( I+1 ) ) - $ IC = IC + 1 - 10 CONTINUE - IF( Q( N-1 ).GT.Q( N ) ) - $ IC = IC + 1 - IF( IC.LT.N ) THEN - CALL DCOPY( N, Q, 1, QQ, -1 ) - CALL DCOPY( N-1, E, 1, EE, -1 ) - IF( KEND.NE.0 ) - $ KEND = N - KEND + 1 - IPHASE = 2 - END IF - ELSE - DO 20 I = 1, N - 2 - IF( QQ( I ).GT.QQ( I+1 ) ) - $ IC = IC + 1 - IF( EE( I ).GT.EE( I+1 ) ) - $ IC = IC + 1 - 20 CONTINUE - IF( QQ( N-1 ).GT.QQ( N ) ) - $ IC = IC + 1 - IF( IC.LT.N ) THEN - CALL DCOPY( N, QQ, 1, Q, -1 ) - CALL DCOPY( N-1, EE, 1, E, -1 ) - IF( KEND.NE.0 ) - $ KEND = N - KEND + 1 - IPHASE = 1 - END IF - END IF - END IF - IF( ICONV.EQ.-3 ) THEN - IF( IPHASE.EQ.1 ) THEN - GO TO 180 - ELSE - GO TO 80 - END IF - END IF - IF( IPHASE.EQ.2 ) - $ GO TO 130 -* -* The ping section of the code -* - 30 CONTINUE - IFL = 0 -* -* Compute the shift -* - IF( KEND.EQ.0 .OR. SUP.EQ.ZERO ) THEN - TAU = ZERO - ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN - TAU = ZERO - ELSE - IP = MAX( IPP, N / NPP ) - N2 = 2*IP + 1 - IF( N2.GE.N ) THEN - N1 = 1 - N2 = N - ELSE IF( KEND+IP.GT.N ) THEN - N1 = N - 2*IP - ELSE IF( KEND-IP.LT.1 ) THEN - N1 = 1 - ELSE - N1 = KEND - IP - END IF - CALL DLASQ4( N2, Q( N1 ), E( N1 ), TAU, SUP ) - END IF - 40 CONTINUE - ICNT = ICNT + 1 - IF( ICNT.GT.MAXIT ) THEN - SUP = -ONE - RETURN - END IF - IF( TAU.EQ.ZERO ) THEN -* -* dqd algorithm -* - D = Q( 1 ) - DM = D - KE = 0 - DO 50 I = 1, N - 3 - QQ( I ) = D + E( I ) - D = ( D / QQ( I ) )*Q( I+1 ) - IF( DM.GT.D ) THEN - DM = D - KE = I - END IF - 50 CONTINUE - KE = KE + 1 -* -* Penultimate dqd step (in ping) -* - K2END = KE - QQ( N-2 ) = D + E( N-2 ) - D = ( D / QQ( N-2 ) )*Q( N-1 ) - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - END IF -* -* Final dqd step (in ping) -* - K1END = KE - QQ( N-1 ) = D + E( N-1 ) - D = ( D / QQ( N-1 ) )*Q( N ) - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - QQ( N ) = D - ELSE -* -* The dqds algorithm (in ping) -* - D = Q( 1 ) - TAU - DM = D - KE = 0 - IF( D.LT.ZERO ) - $ GO TO 120 - DO 60 I = 1, N - 3 - QQ( I ) = D + E( I ) - D = ( D / QQ( I ) )*Q( I+1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = I - IF( D.LT.ZERO ) - $ GO TO 120 - END IF - 60 CONTINUE - KE = KE + 1 -* -* Penultimate dqds step (in ping) -* - K2END = KE - QQ( N-2 ) = D + E( N-2 ) - D = ( D / QQ( N-2 ) )*Q( N-1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - IF( D.LT.ZERO ) - $ GO TO 120 - END IF -* -* Final dqds step (in ping) -* - K1END = KE - QQ( N-1 ) = D + E( N-1 ) - D = ( D / QQ( N-1 ) )*Q( N ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - QQ( N ) = D - END IF -* -* Convergence when QQ(N) is small (in ping) -* - IF( ABS( QQ( N ) ).LE.SIGMA*TOL2 ) THEN - QQ( N ) = ZERO - DM = ZERO - KE = N - END IF - IF( QQ( N ).LT.ZERO ) - $ GO TO 120 -* -* Non-negative qd array: Update the e's -* - DO 70 I = 1, N - 1 - EE( I ) = ( E( I ) / QQ( I ) )*Q( I+1 ) - 70 CONTINUE -* -* Updating sigma and iphase in ping -* - SIGMA = SIGMA + TAU - IPHASE = 2 - 80 CONTINUE - TOLX = SIGMA*TOL2 - TOLY = SIGMA*EPS - TOLZ = MAX( SIGMA, SMALL2 )*TOL2 -* -* Checking for deflation and convergence (in ping) -* - 90 CONTINUE - IF( N.LE.2 ) - $ RETURN -* -* Deflation: bottom 1x1 (in ping) -* - LDEF = .FALSE. - IF( EE( N-1 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( EE( N-1 ).LE.EPS*( SIGMA+QQ( N ) ) ) THEN - IF( EE( N-1 )*( QQ( N ) / ( QQ( N )+SIGMA ) ).LE.TOL2* - $ ( QQ( N )+SIGMA ) ) THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( EE( N-1 ).LE.QQ( N )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - Q( N ) = QQ( N ) + SIGMA - N = N - 1 - ICONV = ICONV + 1 - GO TO 90 - END IF -* -* Deflation: bottom 2x2 (in ping) -* - LDEF = .FALSE. - IF( EE( N-2 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + EE( N-1 )*( SIGMA / ( SIGMA+QQ( N ) ) ) - IF( EE( N-2 )*( T1 / ( QQ( N-1 )+T1 ) ).LE.TOLY ) THEN - IF( EE( N-2 )*( QQ( N-1 ) / ( QQ( N-1 )+T1 ) ).LE.TOLX ) - $ THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( EE( N-2 ).LE.( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )* - $ QQ( N-1 )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1 ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) ) - END IF - YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )* - $ MIN( QQ( N ), QQ( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = SIGMA + XX - Q( N ) = YY + SIGMA - N = N - 2 - ICONV = ICONV + 2 - GO TO 90 - END IF -* -* Updating bounds before going to pong -* - IF( ICONV.EQ.0 ) THEN - KEND = KE - SUP = MIN( DM, SUP-TAU ) - ELSE IF( ICONV.GT.0 ) THEN - SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ), QQ( 1 ), QQ( 2 ), - $ QQ( 3 ) ) - IF( ICONV.EQ.1 ) THEN - KEND = K1END - ELSE IF( ICONV.EQ.2 ) THEN - KEND = K2END - ELSE - KEND = N - END IF - ICNT = 0 - MAXIT = 100*N - END IF -* -* Checking for splitting in ping -* - LSPLIT = .FALSE. - DO 100 KS = N - 3, 3, -1 - IF( EE( KS ).LE.TOLY ) THEN - IF( EE( KS )*( MIN( QQ( KS+1 ), - $ QQ( KS ) ) / ( MIN( QQ( KS+1 ), QQ( KS ) )+SIGMA ) ).LE. - $ TOLX ) THEN - LSPLIT = .TRUE. - GO TO 110 - END IF - END IF - 100 CONTINUE -* - KS = 2 - IF( EE( 2 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + EE( 1 )*( SIGMA / ( SIGMA+QQ( 1 ) ) ) - IF( EE( 2 )*( T1 / ( QQ( 1 )+T1 ) ).LE.TOLY ) THEN - IF( EE( 2 )*( QQ( 1 ) / ( QQ( 1 )+T1 ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( EE( 2 ).LE.( QQ( 1 ) / ( QQ( 1 )+EE( 1 )+QQ( 2 ) ) )* - $ QQ( 2 )*TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF - IF( LSPLIT ) - $ GO TO 110 -* - KS = 1 - IF( EE( 1 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( EE( 1 ).LE.EPS*( SIGMA+QQ( 1 ) ) ) THEN - IF( EE( 1 )*( QQ( 1 ) / ( QQ( 1 )+SIGMA ) ).LE.TOL2* - $ ( QQ( 1 )+SIGMA ) ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( EE( 1 ).LE.QQ( 1 )*TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF -* - 110 CONTINUE - IF( LSPLIT ) THEN - SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ) ) - ISP = -( OFF+1 ) - OFF = OFF + KS - N = N - KS - KEND = MAX( 1, KEND-KS ) - E( KS ) = SIGMA - EE( KS ) = ISP - ICONV = 0 - RETURN - END IF -* -* Coincidence -* - IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ. - $ 0 .AND. ICNT.GT.0 ) THEN - CALL DCOPY( N-KE, E( KE ), 1, QQ( KE ), 1 ) - QQ( N ) = ZERO - CALL DCOPY( N-KE, Q( KE+1 ), 1, EE( KE ), 1 ) - SUP = ZERO - END IF - ICONV = 0 - GO TO 130 -* -* A new shift when the previous failed (in ping) -* - 120 CONTINUE - IFL = IFL + 1 - SUP = TAU -* -* SUP is small or -* Too many bad shifts (ping) -* - IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN - TAU = ZERO - GO TO 40 -* -* The asymptotic shift (in ping) -* - ELSE - TAU = MAX( TAU+D, ZERO ) - IF( TAU.LE.TOLZ ) - $ TAU = ZERO - GO TO 40 - END IF -* -* the pong section of the code -* - 130 CONTINUE - IFL = 0 -* -* Compute the shift (in pong) -* - IF( KEND.EQ.0 .AND. SUP.EQ.ZERO ) THEN - TAU = ZERO - ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN - TAU = ZERO - ELSE - IP = MAX( IPP, N / NPP ) - N2 = 2*IP + 1 - IF( N2.GE.N ) THEN - N1 = 1 - N2 = N - ELSE IF( KEND+IP.GT.N ) THEN - N1 = N - 2*IP - ELSE IF( KEND-IP.LT.1 ) THEN - N1 = 1 - ELSE - N1 = KEND - IP - END IF - CALL DLASQ4( N2, QQ( N1 ), EE( N1 ), TAU, SUP ) - END IF - 140 CONTINUE - ICNT = ICNT + 1 - IF( ICNT.GT.MAXIT ) THEN - SUP = -SUP - RETURN - END IF - IF( TAU.EQ.ZERO ) THEN -* -* The dqd algorithm (in pong) -* - D = QQ( 1 ) - DM = D - KE = 0 - DO 150 I = 1, N - 3 - Q( I ) = D + EE( I ) - D = ( D / Q( I ) )*QQ( I+1 ) - IF( DM.GT.D ) THEN - DM = D - KE = I - END IF - 150 CONTINUE - KE = KE + 1 -* -* Penultimate dqd step (in pong) -* - K2END = KE - Q( N-2 ) = D + EE( N-2 ) - D = ( D / Q( N-2 ) )*QQ( N-1 ) - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - END IF -* -* Final dqd step (in pong) -* - K1END = KE - Q( N-1 ) = D + EE( N-1 ) - D = ( D / Q( N-1 ) )*QQ( N ) - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - Q( N ) = D - ELSE -* -* The dqds algorithm (in pong) -* - D = QQ( 1 ) - TAU - DM = D - KE = 0 - IF( D.LT.ZERO ) - $ GO TO 220 - DO 160 I = 1, N - 3 - Q( I ) = D + EE( I ) - D = ( D / Q( I ) )*QQ( I+1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = I - IF( D.LT.ZERO ) - $ GO TO 220 - END IF - 160 CONTINUE - KE = KE + 1 -* -* Penultimate dqds step (in pong) -* - K2END = KE - Q( N-2 ) = D + EE( N-2 ) - D = ( D / Q( N-2 ) )*QQ( N-1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - IF( D.LT.ZERO ) - $ GO TO 220 - END IF -* -* Final dqds step (in pong) -* - K1END = KE - Q( N-1 ) = D + EE( N-1 ) - D = ( D / Q( N-1 ) )*QQ( N ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - Q( N ) = D - END IF -* -* Convergence when is small (in pong) -* - IF( ABS( Q( N ) ).LE.SIGMA*TOL2 ) THEN - Q( N ) = ZERO - DM = ZERO - KE = N - END IF - IF( Q( N ).LT.ZERO ) - $ GO TO 220 -* -* Non-negative qd array: Update the e's -* - DO 170 I = 1, N - 1 - E( I ) = ( EE( I ) / Q( I ) )*QQ( I+1 ) - 170 CONTINUE -* -* Updating sigma and iphase in pong -* - SIGMA = SIGMA + TAU - 180 CONTINUE - IPHASE = 1 - TOLX = SIGMA*TOL2 - TOLY = SIGMA*EPS -* -* Checking for deflation and convergence (in pong) -* - 190 CONTINUE - IF( N.LE.2 ) - $ RETURN -* -* Deflation: bottom 1x1 (in pong) -* - LDEF = .FALSE. - IF( E( N-1 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( E( N-1 ).LE.EPS*( SIGMA+Q( N ) ) ) THEN - IF( E( N-1 )*( Q( N ) / ( Q( N )+SIGMA ) ).LE.TOL2* - $ ( Q( N )+SIGMA ) ) THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( E( N-1 ).LE.Q( N )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - Q( N ) = Q( N ) + SIGMA - N = N - 1 - ICONV = ICONV + 1 - GO TO 190 - END IF -* -* Deflation: bottom 2x2 (in pong) -* - LDEF = .FALSE. - IF( E( N-2 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + E( N-1 )*( SIGMA / ( SIGMA+Q( N ) ) ) - IF( E( N-2 )*( T1 / ( Q( N-1 )+T1 ) ).LE.TOLY ) THEN - IF( E( N-2 )*( Q( N-1 ) / ( Q( N-1 )+T1 ) ).LE.TOLX ) THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( E( N-2 ).LE.( Q( N ) / ( Q( N )+EE( N-1 )+Q( N-1 ) )*Q( N- - $ 1 ) )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - QEMAX = MAX( Q( N ), Q( N-1 ), E( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.Q( N-1 ) ) THEN - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*E( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.Q( N ) ) THEN - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N-1 )-Q( N )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*E( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*Q( N-1 ) / QEMAX ) ) - END IF - YY = ( MAX( Q( N ), Q( N-1 ) ) / XX )* - $ MIN( Q( N ), Q( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = SIGMA + XX - Q( N ) = YY + SIGMA - N = N - 2 - ICONV = ICONV + 2 - GO TO 190 - END IF -* -* Updating bounds before going to pong -* - IF( ICONV.EQ.0 ) THEN - KEND = KE - SUP = MIN( DM, SUP-TAU ) - ELSE IF( ICONV.GT.0 ) THEN - SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ), Q( 1 ), Q( 2 ), Q( 3 ) ) - IF( ICONV.EQ.1 ) THEN - KEND = K1END - ELSE IF( ICONV.EQ.2 ) THEN - KEND = K2END - ELSE - KEND = N - END IF - ICNT = 0 - MAXIT = 100*N - END IF -* -* Checking for splitting in pong -* - LSPLIT = .FALSE. - DO 200 KS = N - 3, 3, -1 - IF( E( KS ).LE.TOLY ) THEN - IF( E( KS )*( MIN( Q( KS+1 ), Q( KS ) ) / ( MIN( Q( KS+1 ), - $ Q( KS ) )+SIGMA ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - GO TO 210 - END IF - END IF - 200 CONTINUE -* - KS = 2 - IF( E( 2 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + E( 1 )*( SIGMA / ( SIGMA+Q( 1 ) ) ) - IF( E( 2 )*( T1 / ( Q( 1 )+T1 ) ).LE.TOLY ) THEN - IF( E( 2 )*( Q( 1 ) / ( Q( 1 )+T1 ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( E( 2 ).LE.( Q( 1 ) / ( Q( 1 )+E( 1 )+Q( 2 ) ) )*Q( 2 )* - $ TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF - IF( LSPLIT ) - $ GO TO 210 -* - KS = 1 - IF( E( 1 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( E( 1 ).LE.EPS*( SIGMA+Q( 1 ) ) ) THEN - IF( E( 1 )*( Q( 1 ) / ( Q( 1 )+SIGMA ) ).LE.TOL2* - $ ( Q( 1 )+SIGMA ) ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( E( 1 ).LE.Q( 1 )*TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF -* - 210 CONTINUE - IF( LSPLIT ) THEN - SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ) ) - ISP = OFF + 1 - OFF = OFF + KS - KEND = MAX( 1, KEND-KS ) - N = N - KS - E( KS ) = SIGMA - EE( KS ) = ISP - ICONV = 0 - RETURN - END IF -* -* Coincidence -* - IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ. - $ 0 .AND. ICNT.GT.0 ) THEN - CALL DCOPY( N-KE, EE( KE ), 1, Q( KE ), 1 ) - Q( N ) = ZERO - CALL DCOPY( N-KE, QQ( KE+1 ), 1, E( KE ), 1 ) - SUP = ZERO - END IF - ICONV = 0 - GO TO 30 -* -* Computation of a new shift when the previous failed (in pong) -* - 220 CONTINUE - IFL = IFL + 1 - SUP = TAU -* -* SUP is small or -* Too many bad shifts (in pong) -* - IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN - TAU = ZERO - GO TO 140 -* -* The asymptotic shift (in pong) -* - ELSE - TAU = MAX( TAU+D, ZERO ) - IF( TAU.LE.TOLZ ) - $ TAU = ZERO - GO TO 140 - END IF -* -* End of DLASQ3 -* - END diff --git a/Cantera/ext/lapack/dlasq4.f b/Cantera/ext/lapack/dlasq4.f deleted file mode 100755 index d410bae5d..000000000 --- a/Cantera/ext/lapack/dlasq4.f +++ /dev/null @@ -1,103 +0,0 @@ - SUBROUTINE DLASQ4( N, Q, E, TAU, SUP ) -* -* -- 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 N - DOUBLE PRECISION SUP, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ), Q( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ4 estimates TAU, the smallest eigenvalue of a matrix. This -* routine improves the input value of SUP which is an upper bound -* for the smallest eigenvalue for this matrix . -* -* Arguments -* ========= -* -* N (input) INTEGER -* On entry, N specifies the number of rows and columns -* in the matrix. N must be at least 0. -* -* Q (input) DOUBLE PRECISION array, dimension (N) -* Q array -* -* E (input) DOUBLE PRECISION array, dimension (N) -* E array -* -* TAU (output) DOUBLE PRECISION -* Estimate of the shift -* -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest singular value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION BIS, BIS1 - PARAMETER ( BIS = 0.9999D+0, BIS1 = 0.7D+0 ) - INTEGER IFLMAX - PARAMETER ( IFLMAX = 5 ) -* .. -* .. Local Scalars .. - INTEGER I, IFL - DOUBLE PRECISION D, DM, XINF -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - IFL = 1 - SUP = MIN( SUP, Q( 1 ), Q( 2 ), Q( 3 ), Q( N ), Q( N-1 ), - $ Q( N-2 ) ) - TAU = SUP*BIS - XINF = ZERO - 10 CONTINUE - IF( IFL.EQ.IFLMAX ) THEN - TAU = XINF - RETURN - END IF - D = Q( 1 ) - TAU - DM = D - DO 20 I = 1, N - 2 - D = ( D / ( D+E( I ) ) )*Q( I+1 ) - TAU - IF( DM.GT.D ) - $ DM = D - IF( D.LT.ZERO ) THEN - SUP = TAU - TAU = MAX( SUP*BIS1**IFL, D+TAU ) - IFL = IFL + 1 - GO TO 10 - END IF - 20 CONTINUE - D = ( D / ( D+E( N-1 ) ) )*Q( N ) - TAU - IF( DM.GT.D ) - $ DM = D - IF( D.LT.ZERO ) THEN - SUP = TAU - XINF = MAX( XINF, D+TAU ) - IF( SUP*BIS1**IFL.LE.XINF ) THEN - TAU = XINF - ELSE - TAU = SUP*BIS1**IFL - IFL = IFL + 1 - GO TO 10 - END IF - ELSE - SUP = MIN( SUP, DM+TAU ) - END IF - RETURN -* -* End of DLASQ4 -* - END diff --git a/Cantera/ext/lapack/dlasr.f b/Cantera/ext/lapack/dlasr.f deleted file mode 100755 index 9bf39ac70..000000000 --- a/Cantera/ext/lapack/dlasr.f +++ /dev/null @@ -1,325 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlasrt.f b/Cantera/ext/lapack/dlasrt.f deleted file mode 100755 index 7b22eb3f1..000000000 --- a/Cantera/ext/lapack/dlasrt.f +++ /dev/null @@ -1,244 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlassq.f b/Cantera/ext/lapack/dlassq.f deleted file mode 100755 index 9518d06ab..000000000 --- a/Cantera/ext/lapack/dlassq.f +++ /dev/null @@ -1,89 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dlasv2.f b/Cantera/ext/lapack/dlasv2.f deleted file mode 100755 index 0fc7835dc..000000000 --- a/Cantera/ext/lapack/dlasv2.f +++ /dev/null @@ -1,250 +0,0 @@ - SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* -* -- 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 CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN -* .. -* -* Purpose -* ======= -* -* DLASV2 computes the singular value decomposition of a 2-by-2 -* triangular matrix -* [ F G ] -* [ 0 H ]. -* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the -* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and -* right singular vectors for abs(SSMAX), giving the decomposition -* -* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] -* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. -* -* Arguments -* ========= -* -* F (input) DOUBLE PRECISION -* The (1,1) element of the 2-by-2 matrix. -* -* G (input) DOUBLE PRECISION -* The (1,2) element of the 2-by-2 matrix. -* -* H (input) DOUBLE PRECISION -* The (2,2) element of the 2-by-2 matrix. -* -* SSMIN (output) DOUBLE PRECISION -* abs(SSMIN) is the smaller singular value. -* -* SSMAX (output) DOUBLE PRECISION -* abs(SSMAX) is the larger singular value. -* -* SNL (output) DOUBLE PRECISION -* CSL (output) DOUBLE PRECISION -* The vector (CSL, SNL) is a unit left singular vector for the -* singular value abs(SSMAX). -* -* SNR (output) DOUBLE PRECISION -* CSR (output) DOUBLE PRECISION -* The vector (CSR, SNR) is a unit right singular vector for the -* singular value abs(SSMAX). -* -* Further Details -* =============== -* -* Any input parameter may be aliased with any output parameter. -* -* Barring over/underflow and assuming a guard digit in subtraction, all -* output quantities are correct to within a few units in the last -* place (ulps). -* -* In IEEE arithmetic, the code works correctly if one matrix element is -* infinite. -* -* Overflow will not occur unless the largest singular value itself -* overflows or is within a few ulps of overflow. (On machines with -* partial overflow, like the Cray, overflow may occur if the largest -* singular value is within a factor of 2 of overflow.) -* -* Underflow is harmless if underflow is gradual. Otherwise, results -* may correspond to a matrix modified by perturbations of size near -* the underflow threshold. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION FOUR - PARAMETER ( FOUR = 4.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL GASMAL, SWAP - INTEGER PMAX - DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, - $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Executable Statements .. -* - FT = F - FA = ABS( FT ) - HT = H - HA = ABS( H ) -* -* PMAX points to the maximum absolute element of matrix -* PMAX = 1 if F largest in absolute values -* PMAX = 2 if G largest in absolute values -* PMAX = 3 if H largest in absolute values -* - PMAX = 1 - SWAP = ( HA.GT.FA ) - IF( SWAP ) THEN - PMAX = 3 - TEMP = FT - FT = HT - HT = TEMP - TEMP = FA - FA = HA - HA = TEMP -* -* Now FA .ge. HA -* - END IF - GT = G - GA = ABS( GT ) - IF( GA.EQ.ZERO ) THEN -* -* Diagonal matrix -* - SSMIN = HA - SSMAX = FA - CLT = ONE - CRT = ONE - SLT = ZERO - SRT = ZERO - ELSE - GASMAL = .TRUE. - IF( GA.GT.FA ) THEN - PMAX = 2 - IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN -* -* Case of very large GA -* - GASMAL = .FALSE. - SSMAX = GA - IF( HA.GT.ONE ) THEN - SSMIN = FA / ( GA / HA ) - ELSE - SSMIN = ( FA / GA )*HA - END IF - CLT = ONE - SLT = HT / GT - SRT = ONE - CRT = FT / GT - END IF - END IF - IF( GASMAL ) THEN -* -* Normal case -* - D = FA - HA - IF( D.EQ.FA ) THEN -* -* Copes with infinite F or H -* - L = ONE - ELSE - L = D / FA - END IF -* -* Note that 0 .le. L .le. 1 -* - M = GT / FT -* -* Note that abs(M) .le. 1/macheps -* - T = TWO - L -* -* Note that T .ge. 1 -* - MM = M*M - TT = T*T - S = SQRT( TT+MM ) -* -* Note that 1 .le. S .le. 1 + 1/macheps -* - IF( L.EQ.ZERO ) THEN - R = ABS( M ) - ELSE - R = SQRT( L*L+MM ) - END IF -* -* Note that 0 .le. R .le. 1 + 1/macheps -* - A = HALF*( S+R ) -* -* Note that 1 .le. A .le. 1 + abs(M) -* - SSMIN = HA / A - SSMAX = FA*A - IF( MM.EQ.ZERO ) THEN -* -* Note that M is very tiny -* - IF( L.EQ.ZERO ) THEN - T = SIGN( TWO, FT )*SIGN( ONE, GT ) - ELSE - T = GT / SIGN( D, FT ) + M / T - END IF - ELSE - T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) - END IF - L = SQRT( T*T+FOUR ) - CRT = TWO / L - SRT = T / L - CLT = ( CRT+SRT*M ) / A - SLT = ( HT / FT )*SRT / A - END IF - END IF - IF( SWAP ) THEN - CSL = SRT - SNL = CRT - CSR = SLT - SNR = CLT - ELSE - CSL = CLT - SNL = SLT - CSR = CRT - SNR = SRT - END IF -* -* Correct signs of SSMAX and SSMIN -* - IF( PMAX.EQ.1 ) - $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) - IF( PMAX.EQ.2 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) - IF( PMAX.EQ.3 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) - SSMAX = SIGN( SSMAX, TSIGN ) - SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) - RETURN -* -* End of DLASV2 -* - END diff --git a/Cantera/ext/lapack/dlaswp.f b/Cantera/ext/lapack/dlaswp.f deleted file mode 100755 index 99c0dda27..000000000 --- a/Cantera/ext/lapack/dlaswp.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END diff --git a/Cantera/ext/lapack/dorg2r.f b/Cantera/ext/lapack/dorg2r.f deleted file mode 100755 index 8ecd83de6..000000000 --- a/Cantera/ext/lapack/dorg2r.f +++ /dev/null @@ -1,130 +0,0 @@ - SUBROUTINE DORG2R( M, N, K, 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, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORG2R generates an m by n real matrix Q with orthonormal columns, -* which is defined as the first n columns of a product of k elementary -* reflectors of order m -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, 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. -* On exit, the m-by-n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2R -* - END diff --git a/Cantera/ext/lapack/dorgbr.f b/Cantera/ext/lapack/dorgbr.f deleted file mode 100755 index ed8aa80ac..000000000 --- a/Cantera/ext/lapack/dorgbr.f +++ /dev/null @@ -1,223 +0,0 @@ - SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER VECT - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORGBR generates one of the real orthogonal matrices Q or P**T -* determined by DGEBRD when reducing a real matrix A to bidiagonal -* form: A = Q * B * P**T. Q and P**T are defined as products of -* elementary reflectors H(i) or G(i) respectively. -* -* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q -* is of order M: -* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n -* columns of Q, where m >= n >= k; -* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an -* M-by-M matrix. -* -* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T -* is of order N: -* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m -* rows of P**T, where n >= m >= k; -* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as -* an N-by-N matrix. -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* Specifies whether the matrix Q or the matrix P**T is -* required, as defined in the transformation applied by DGEBRD: -* = 'Q': generate Q; -* = 'P': generate P**T. -* -* M (input) INTEGER -* The number of rows of the matrix Q or P**T to be returned. -* M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q or P**T to be returned. -* N >= 0. -* If VECT = 'Q', M >= N >= min(M,K); -* if VECT = 'P', N >= M >= min(N,K). -* -* K (input) INTEGER -* If VECT = 'Q', the number of columns in the original M-by-K -* matrix reduced by DGEBRD. -* If VECT = 'P', the number of rows in the original K-by-N -* matrix reduced by DGEBRD. -* K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the vectors which define the elementary reflectors, -* as returned by DGEBRD. -* On exit, the M-by-N matrix Q or P**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension -* (min(M,K)) if VECT = 'Q' -* (min(N,K)) if VECT = 'P' -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i) or G(i), which determines Q or P**T, as -* returned by DGEBRD in its array argument TAUQ or TAUP. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,min(M,N)). -* For optimum performance LWORK >= min(M,N)*NB, where NB -* is the optimal blocksize. -* -* 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.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL WANTQ - INTEGER I, IINFO, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DORGLQ, DORGQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - WANTQ = LSAME( VECT, 'Q' ) - IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, - $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. - $ MIN( N, K ) ) ) ) THEN - INFO = -3 - ELSE IF( K.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LWORK.LT.MAX( 1, MIN( M, N ) ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGBR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( WANTQ ) THEN -* -* Form Q, determined by a call to DGEBRD to reduce an m-by-k -* matrix -* - IF( M.GE.K ) THEN -* -* If m >= k, assume m >= n >= k -* - CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If m < k, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q -* to those of the unit matrix -* - DO 20 J = M, 2, -1 - A( 1, J ) = ZERO - DO 10 I = J + 1, M - A( I, J ) = A( I, J-1 ) - 10 CONTINUE - 20 CONTINUE - A( 1, 1 ) = ONE - DO 30 I = 2, M - A( I, 1 ) = ZERO - 30 CONTINUE - IF( M.GT.1 ) THEN -* -* Form Q(2:m,2:m) -* - CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - ELSE -* -* Form P', determined by a call to DGEBRD to reduce a k-by-n -* matrix -* - IF( K.LT.N ) THEN -* -* If k < n, assume k <= m <= n -* - CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If k >= n, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* row downward, and set the first row and column of P' to -* those of the unit matrix -* - A( 1, 1 ) = ONE - DO 40 I = 2, N - A( I, 1 ) = ZERO - 40 CONTINUE - DO 60 J = 2, N - DO 50 I = J - 1, 2, -1 - A( I, J ) = A( I-1, J ) - 50 CONTINUE - A( 1, J ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Form P'(2:n,2:n) -* - CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - END IF - RETURN -* -* End of DORGBR -* - END diff --git a/Cantera/ext/lapack/dorgl2.f b/Cantera/ext/lapack/dorgl2.f deleted file mode 100755 index 76274955d..000000000 --- a/Cantera/ext/lapack/dorgl2.f +++ /dev/null @@ -1,134 +0,0 @@ - SUBROUTINE DORGL2( M, N, K, 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, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGL2 generates an m by n real matrix Q with orthonormal rows, -* which is defined as the first m rows of a product of k elementary -* reflectors of order n -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. N >= M. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. M >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th row must contain the vector which defines -* the elementary reflector H(i), for i = 1,2,...,k, as returned -* by DGELQF in the first k rows of its array argument A. -* On exit, the m-by-n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (M) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGL2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) - $ RETURN -* - IF( K.LT.M ) THEN -* -* Initialise rows k+1:m to rows of the unit matrix -* - DO 20 J = 1, N - DO 10 L = K + 1, M - A( L, J ) = ZERO - 10 CONTINUE - IF( J.GT.K .AND. J.LE.M ) - $ A( J, J ) = ONE - 20 CONTINUE - END IF -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the right -* - IF( I.LT.N ) THEN - IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), A( I+1, I ), LDA, WORK ) - END IF - CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) - END IF - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( I, L ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORGL2 -* - END diff --git a/Cantera/ext/lapack/dorglq.f b/Cantera/ext/lapack/dorglq.f deleted file mode 100755 index a266be514..000000000 --- a/Cantera/ext/lapack/dorglq.f +++ /dev/null @@ -1,207 +0,0 @@ - SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORGLQ generates an M-by-N real matrix Q with orthonormal rows, -* which is defined as the first M rows of a product of K elementary -* reflectors of order N -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. N >= M. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. M >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th row must contain the vector which defines -* the elementary reflector H(i), for i = 1,2,...,k, as returned -* by DGELQF in the first k rows of its array argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,M). -* For optimum performance LWORK >= M*NB, where NB is -* the optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGLQ', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk rows are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(kk+1:m,1:kk) to zero. -* - DO 20 J = 1, KK - DO 10 I = KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.M ) - $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H' to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', - $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, - $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), - $ LDWORK ) - END IF -* -* Apply H' to columns i:n of current block -* - CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set columns 1:i-1 of current block to zero -* - DO 40 J = 1, I - 1 - DO 30 L = I, I + IB - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGLQ -* - END diff --git a/Cantera/ext/lapack/dorgqr.f b/Cantera/ext/lapack/dorgqr.f deleted file mode 100755 index c16ac6d83..000000000 --- a/Cantera/ext/lapack/dorgqr.f +++ /dev/null @@ -1,208 +0,0 @@ - SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORGQR generates an M-by-N real matrix Q with orthonormal columns, -* which is defined as the first N columns of a product of K elementary -* reflectors of order M -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, 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. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQR -* - END diff --git a/Cantera/ext/lapack/dorm2r.f b/Cantera/ext/lapack/dorm2r.f deleted file mode 100755 index 74dd845ef..000000000 --- a/Cantera/ext/lapack/dorm2r.f +++ /dev/null @@ -1,198 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/dormbr.f b/Cantera/ext/lapack/dormbr.f deleted file mode 100755 index 5002fb511..000000000 --- a/Cantera/ext/lapack/dormbr.f +++ /dev/null @@ -1,250 +0,0 @@ - SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, - $ LDC, 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, VECT - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C -* with -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C -* with -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': P * C C * P -* TRANS = 'T': P**T * C C * P**T -* -* Here Q and P**T are the orthogonal matrices determined by DGEBRD when -* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and -* P**T are defined as products of elementary reflectors H(i) and G(i) -* respectively. -* -* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the -* order of the orthogonal matrix Q or P**T that is applied. -* -* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: -* if nq >= k, Q = H(1) H(2) . . . H(k); -* if nq < k, Q = H(1) H(2) . . . H(nq-1). -* -* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: -* if k < nq, P = G(1) G(2) . . . G(k); -* if k >= nq, P = G(1) G(2) . . . G(nq-1). -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* = 'Q': apply Q or Q**T; -* = 'P': apply P or P**T. -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q, Q**T, P or P**T from the Left; -* = 'R': apply Q, Q**T, P or P**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q or P; -* = 'T': Transpose, apply Q**T or P**T. -* -* 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 -* If VECT = 'Q', the number of columns in the original -* matrix reduced by DGEBRD. -* If VECT = 'P', the number of rows in the original -* matrix reduced by DGEBRD. -* K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension -* (LDA,min(nq,K)) if VECT = 'Q' -* (LDA,nq) if VECT = 'P' -* The vectors which define the elementary reflectors H(i) and -* G(i), whose products determine the matrices Q and P, as -* returned by DGEBRD. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If VECT = 'Q', LDA >= max(1,nq); -* if VECT = 'P', LDA >= max(1,min(nq,K)). -* -* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i) or G(i) which determines Q or P, as returned -* by DGEBRD in the array argument TAUQ or TAUP. -* -* 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**T*C or C*Q**T or C*Q -* or P*C or P**T*C or C*P or C*P**T. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL APPLYQ, LEFT, NOTRAN - CHARACTER TRANST - INTEGER I1, I2, IINFO, MI, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DORMLQ, DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - APPLYQ = LSAME( VECT, 'Q' ) - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q or P and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( K.LT.0 ) THEN - INFO = -6 - ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. - $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) - $ THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMBR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - WORK( 1 ) = 1 - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - IF( APPLYQ ) THEN -* -* Apply Q -* - IF( NQ.GE.K ) THEN -* -* Q was determined by a call to DGEBRD with nq >= k -* - CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* Q was determined by a call to DGEBRD with nq < k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - ELSE -* -* Apply P -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF - IF( NQ.GT.K ) THEN -* -* P was determined by a call to DGEBRD with nq > k -* - CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* P was determined by a call to DGEBRD with nq <= k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, - $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - END IF - RETURN -* -* End of DORMBR -* - END diff --git a/Cantera/ext/lapack/dorml2.f b/Cantera/ext/lapack/dorml2.f deleted file mode 100755 index bb789d864..000000000 --- a/Cantera/ext/lapack/dorml2.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE DORML2( 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 -* ======= -* -* DORML2 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(k) . . . H(2) H(1) -* -* as returned by DGELQF. 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,M) if SIDE = 'L', -* (LDA,N) if SIDE = 'R' -* The i-th row must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGELQF in the first k rows 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. LDA >= max(1,K). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* 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, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORML2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.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 ), LDA, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORML2 -* - END diff --git a/Cantera/ext/lapack/dormlq.f b/Cantera/ext/lapack/dormlq.f deleted file mode 100755 index cb5c9fae3..000000000 --- a/Cantera/ext/lapack/dormlq.f +++ /dev/null @@ -1,254 +0,0 @@ - SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORMLQ overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. 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**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* 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,M) if SIDE = 'L', -* (LDA,N) if SIDE = 'R' -* The i-th row must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGELQF in the first k rows 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. LDA >= max(1,K). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* 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**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - CHARACTER TRANST - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORML2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - 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, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMLQ', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H' -* - CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, - $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, - $ LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = IWS - RETURN -* -* End of DORMLQ -* - END diff --git a/Cantera/ext/lapack/dormqr.f b/Cantera/ext/lapack/dormqr.f deleted file mode 100755 index 0700bcdbf..000000000 --- a/Cantera/ext/lapack/dormqr.f +++ /dev/null @@ -1,247 +0,0 @@ - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ 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 -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORMQR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**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**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* 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**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - 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 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H' -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = IWS - RETURN -* -* End of DORMQR -* - END diff --git a/Cantera/ext/lapack/drscl.f b/Cantera/ext/lapack/drscl.f deleted file mode 100755 index 00628b300..000000000 --- a/Cantera/ext/lapack/drscl.f +++ /dev/null @@ -1,115 +0,0 @@ - SUBROUTINE DRSCL( N, SA, SX, 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 - DOUBLE PRECISION SA -* .. -* .. Array Arguments .. - DOUBLE PRECISION SX( * ) -* .. -* -* Purpose -* ======= -* -* DRSCL multiplies an n-element real vector x by the real scalar 1/a. -* This is done without overflow or underflow as long as -* the final result x/a does not overflow or underflow. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of components of the vector x. -* -* SA (input) DOUBLE PRECISION -* The scalar a which is used to divide each component of x. -* SA must be >= 0, or the subroutine will divide by zero. -* -* SX (input/output) DOUBLE PRECISION array, dimension -* (1+(N-1)*abs(INCX)) -* The n-element vector x. -* -* INCX (input) INTEGER -* The increment between successive values of the vector SX. -* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, DSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Initialize the denominator to SA and the numerator to 1. -* - CDEN = SA - CNUM = ONE -* - 10 CONTINUE - CDEN1 = CDEN*SMLNUM - CNUM1 = CNUM / BIGNUM - IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN -* -* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. -* - MUL = SMLNUM - DONE = .FALSE. - CDEN = CDEN1 - ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN -* -* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. -* - MUL = BIGNUM - DONE = .FALSE. - CNUM = CNUM1 - ELSE -* -* Multiply X by CNUM / CDEN and return. -* - MUL = CNUM / CDEN - DONE = .TRUE. - END IF -* -* Scale the vector X by MUL -* - CALL DSCAL( N, MUL, SX, INCX ) -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DRSCL -* - END diff --git a/Cantera/ext/lapack/ilaenv.f b/Cantera/ext/lapack/ilaenv.f deleted file mode 100755 index e3d296a88..000000000 --- a/Cantera/ext/lapack/ilaenv.f +++ /dev/null @@ -1,506 +0,0 @@ - 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 diff --git a/Cantera/ext/lapack/lsame.f b/Cantera/ext/lapack/lsame.f deleted file mode 100755 index db133b544..000000000 --- a/Cantera/ext/lapack/lsame.f +++ /dev/null @@ -1,87 +0,0 @@ - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* 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 diff --git a/Cantera/ext/lapack/xerbla.f b/Cantera/ext/lapack/xerbla.f deleted file mode 100755 index 618dfcf97..000000000 --- a/Cantera/ext/lapack/xerbla.f +++ /dev/null @@ -1,46 +0,0 @@ - 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