| Revision: | 1.1 |
| Committed: | Wed Sep 17 04:01:49 2008 UTC (16 years, 7 months ago) by loizides |
| Branch: | MAIN |
| CVS Tags: | Mit_032, Mit_031, Mit_025c_branch2, Mit_025c_branch1, Mit_030, Mit_029c, Mit_030_pre1, Mit_029a, Mit_029, Mit_029_pre1, Mit_028a, Mit_025c_branch0, Mit_028, Mit_027a, Mit_027, Mit_026, Mit_025e, Mit_025d, Mit_025c, Mit_025b, Mit_025a, Mit_025, Mit_025pre2, Mit_024b, Mit_025pre1, Mit_024a, Mit_024, Mit_023, Mit_022a, Mit_022, Mit_020d, TMit_020d, Mit_020c, Mit_021, Mit_021pre2, Mit_021pre1, Mit_020b, Mit_020a, Mit_020, Mit_020pre1, Mit_018, Mit_017, Mit_017pre3, Mit_017pre2, Mit_017pre1, V07-05-00, Mit_016, Mit_015b, Mit_015a, Mit_015, Mit_014e, Mit_014d, Mit_014c, Mit_014b, ConvRejection-10-06-09, Mit_014a, Mit_014, Mit_014pre3, Mit_014pre2, Mit_014pre1, Mit_013d, Mit_013c, Mit_013b, Mit_013a, Mit_013, Mit_013pre1, Mit_012i, Mit_012g, Mit_012f, Mit_012e, Mit_012d, Mit_012c, Mit_012b, Mit_012a, Mit_012, Mit_011a, Mit_011, Mit_010a, Mit_010, Mit_009c, Mit_009b, Mit_009a, Mit_009, Mit_008, Mit_008pre2, Mit_008pre1, Mit_006b, Mit_006a, Mit_006, Mit_005, Mit_004, HEAD |
| Branch point for: | Mit_025c_branch |
| Log Message: | Moved MitVertex contents to MitCommon. MitVertex therefore is obsolute and should not be touched anymore. |
| # | User | Rev | Content |
|---|---|---|---|
| 1 | loizides | 1.1 | c $Id:$ |
| 2 | |||
| 3 | SUBROUTINE DFACT(N,A,IDIM,IR,IFAIL,DET,JFAIL) | ||
| 4 | INTEGER IR(*), IPAIRF | ||
| 5 | DOUBLE PRECISION A(IDIM,*),DET, ZERO, ONE,X,Y,TF | ||
| 6 | REAL G1, G2 | ||
| 7 | REAL PIVOTF, P, Q, SIZEF, T | ||
| 8 | DOUBLE PRECISION S11, S12, DOTF | ||
| 9 | CHARACTER*6 HNAME | ||
| 10 | C | ||
| 11 | INTEGER J,K,N,IDIM,IFAIL,JFAIL,NORMAL,JRANGE,NXCH | ||
| 12 | INTEGER JP1,I,IMPOSS,L,JUNDER,JOVER,JM1 | ||
| 13 | c | ||
| 14 | IPAIRF(J,K) = J*2**12 + K | ||
| 15 | PIVOTF(X) = ABS(SNGL(X)) | ||
| 16 | SIZEF(X) = ABS(SNGL(X)) | ||
| 17 | DOTF(X,Y,S11) = X * Y + S11 | ||
| 18 | |||
| 19 | DATA G1, G2 / 1.E-19, 1.E19 / | ||
| 20 | DATA HNAME / ' DFACT' / | ||
| 21 | DATA ZERO, ONE / 0.D0, 1.D0 / | ||
| 22 | DATA NORMAL, IMPOSS / 0, -1 / | ||
| 23 | DATA JRANGE, JOVER, JUNDER / 0, +1, -1 / | ||
| 24 | c$$$ #include "fact.inc" | ||
| 25 | * fact.inc | ||
| 26 | * | ||
| 27 | IF(IDIM .GE. N .AND. N .GT. 0) GOTO 110 | ||
| 28 | c$$$ CALL TMPRNT(HNAME,N,IDIM,0) | ||
| 29 | RETURN | ||
| 30 | 110 IFAIL = NORMAL | ||
| 31 | JFAIL = JRANGE | ||
| 32 | NXCH = 0 | ||
| 33 | DET = ONE | ||
| 34 | DO 144 J = 1, N | ||
| 35 | 120 K = J | ||
| 36 | P = PIVOTF(A(J,J)) | ||
| 37 | IF(J .EQ. N) GOTO 122 | ||
| 38 | JP1 = J+1 | ||
| 39 | DO 121 I = JP1, N | ||
| 40 | Q = PIVOTF(A(I,J)) | ||
| 41 | IF(Q .LE. P) GOTO 121 | ||
| 42 | K = I | ||
| 43 | P = Q | ||
| 44 | 121 CONTINUE | ||
| 45 | IF(K .NE. J) GOTO 123 | ||
| 46 | 122 IF(P .GT. 0.) GOTO 130 | ||
| 47 | DET = ZERO | ||
| 48 | IFAIL = IMPOSS | ||
| 49 | JFAIL = JRANGE | ||
| 50 | RETURN | ||
| 51 | 123 DO 124 L = 1, N | ||
| 52 | TF = A(J,L) | ||
| 53 | A(J,L) = A(K,L) | ||
| 54 | A(K,L) = TF | ||
| 55 | 124 CONTINUE | ||
| 56 | NXCH = NXCH + 1 | ||
| 57 | IR(NXCH) = IPAIRF(J,K) | ||
| 58 | 130 DET = DET * A(J,J) | ||
| 59 | A(J,J) = ONE / A(J,J) | ||
| 60 | T = SIZEF(DET) | ||
| 61 | IF(T .LT. G1) THEN | ||
| 62 | DET = ZERO | ||
| 63 | IF(JFAIL .EQ. JRANGE) JFAIL = JUNDER | ||
| 64 | ELSEIF(T .GT. G2) THEN | ||
| 65 | DET = ONE | ||
| 66 | IF(JFAIL .EQ. JRANGE) JFAIL = JOVER | ||
| 67 | ENDIF | ||
| 68 | IF(J .EQ. N) GOTO 144 | ||
| 69 | JM1 = J-1 | ||
| 70 | JP1 = J+1 | ||
| 71 | DO 143 K = JP1, N | ||
| 72 | S11 = -A(J,K) | ||
| 73 | S12 = -A(K,J+1) | ||
| 74 | IF(J .EQ. 1) GOTO 142 | ||
| 75 | DO 141 I = 1, JM1 | ||
| 76 | S11 = DOTF(A(I,K),A(J,I),S11) | ||
| 77 | S12 = DOTF(A(I,J+1),A(K,I),S12) | ||
| 78 | 141 CONTINUE | ||
| 79 | 142 A(J,K) = -S11 * A(J,J) | ||
| 80 | A(K,J+1) = -DOTF(A(J,J+1),A(K,J),S12) | ||
| 81 | 143 CONTINUE | ||
| 82 | 144 CONTINUE | ||
| 83 | 150 IF(MOD(NXCH,2) .NE. 0) DET = -DET | ||
| 84 | IF(JFAIL .NE. JRANGE) DET = ZERO | ||
| 85 | IR(N) = NXCH | ||
| 86 | RETURN | ||
| 87 | END |