Mercurial > hg > octave-lojdl
diff libcruft/linpack/dgeco.f @ 2329:30c606bec7a8
[project @ 1996-07-19 01:29:05 by jwe]
Initial revision
author | jwe |
---|---|
date | Fri, 19 Jul 1996 01:29:55 +0000 |
parents | |
children |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/libcruft/linpack/dgeco.f @@ -0,0 +1,193 @@ + SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) + INTEGER LDA,N,IPVT(1) + DOUBLE PRECISION A(LDA,1),Z(1) + DOUBLE PRECISION RCOND +C +C DGECO FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION +C AND ESTIMATES THE CONDITION OF THE MATRIX. +C +C IF RCOND IS NOT NEEDED, DGEFA IS SLIGHTLY FASTER. +C TO SOLVE A*X = B , FOLLOW DGECO BY DGESL. +C TO COMPUTE INVERSE(A)*C , FOLLOW DGECO BY DGESL. +C TO COMPUTE DETERMINANT(A) , FOLLOW DGECO BY DGEDI. +C TO COMPUTE INVERSE(A) , FOLLOW DGECO BY DGEDI. +C +C ON ENTRY +C +C A DOUBLE PRECISION(LDA, N) +C THE MATRIX TO BE FACTORED. +C +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C +C N INTEGER +C THE ORDER OF THE MATRIX A . +C +C ON RETURN +C +C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS +C WHICH WERE USED TO OBTAIN IT. +C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE +C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER +C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. +C +C IPVT INTEGER(N) +C AN INTEGER VECTOR OF PIVOT INDICES. +C +C RCOND DOUBLE PRECISION +C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . +C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS +C IN A AND B OF SIZE EPSILON MAY CAUSE +C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . +C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION +C 1.0 + RCOND .EQ. 1.0 +C IS TRUE, THEN A MAY BE SINGULAR TO WORKING +C PRECISION. IN PARTICULAR, RCOND IS ZERO IF +C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE +C UNDERFLOWS. +C +C Z DOUBLE PRECISION(N) +C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. +C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS +C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT +C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . +C +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C +C SUBROUTINES AND FUNCTIONS +C +C LINPACK DGEFA +C BLAS DAXPY,DDOT,DSCAL,DASUM +C FORTRAN DABS,DMAX1,DSIGN +C +C INTERNAL VARIABLES +C + DOUBLE PRECISION DDOT,EK,T,WK,WKM + DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM + INTEGER INFO,J,K,KB,KP1,L +C +C +C COMPUTE 1-NORM OF A +C + ANORM = 0.0D0 + DO 10 J = 1, N + ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) + 10 CONTINUE +C +C FACTOR +C + CALL DGEFA(A,LDA,N,IPVT,INFO) +C +C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . +C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE +C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE +C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID +C OVERFLOW. +C +C SOLVE TRANS(U)*W = E +C + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 K = 1, N + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 + S = DABS(A(K,K))/DABS(EK-Z(K)) + CALL DSCAL(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = DABS(WK) + SM = DABS(WKM) + IF (A(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/A(K,K) + WKM = WKM/A(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + KP1 = K + 1 + IF (KP1 .GT. N) GO TO 90 + DO 60 J = KP1, N + SM = SM + DABS(Z(J)+WKM*A(K,J)) + Z(J) = Z(J) + WK*A(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + T = WKM - WK + WK = WKM + DO 70 J = KP1, N + Z(J) = Z(J) + T*A(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C +C SOLVE TRANS(L)*Y = W +C + DO 120 KB = 1, N + K = N + 1 - KB + IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) + IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 + S = 1.0D0/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + 110 CONTINUE + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + 120 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) +C + YNORM = 1.0D0 +C +C SOLVE L*V = Y +C + DO 140 K = 1, N + L = IPVT(K) + T = Z(L) + Z(L) = Z(K) + Z(K) = T + IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) + IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 + S = 1.0D0/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 130 CONTINUE + 140 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C +C SOLVE U*Z = V +C + DO 160 KB = 1, N + K = N + 1 - KB + IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 + S = DABS(A(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 150 CONTINUE + IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) + IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + T = -Z(K) + CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) + 160 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM +C + IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM + IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END