| fe4da5cc |
1 | * |
| 2 | * $Id$ |
| 3 | * |
| 4 | * $Log$ |
| 5 | * Revision 1.1.1.1 1996/04/01 15:02:49 mclareni |
| 6 | * Mathlib gen |
| 7 | * |
| 8 | * |
| 9 | #include "gen/pilot.h" |
| 10 | SUBROUTINE H101S1(A,B,C,Z,M,N,IDA,IP,KP,LW,IDW,EPS) |
| 11 | |
| 12 | #include "gen/imp64.inc" |
| 13 | |
| 14 | DIMENSION A(IDA,*),B(*),C(*),LW(IDW,*) |
| 15 | |
| 16 | PARAMETER (R10 = 10, IE0 = 15) |
| 17 | |
| 18 | C Exchanges a basic with a non-basic variable and transforms |
| 19 | C the whole tableau |
| 20 | |
| 21 | A(IP,KP)=1/A(IP,KP) |
| 22 | DO 1 I = 1,M |
| 23 | IF(I .NE. IP) A(I,KP)=A(I,KP)*A(IP,KP) |
| 24 | 1 CONTINUE |
| 25 | C(KP)=C(KP)*A(IP,KP) |
| 26 | DO 3 I = 1,M |
| 27 | IF(I .NE. IP) THEN |
| 28 | DO 2 K = 1,N |
| 29 | IF(K .NE. KP) A(I,K)=A(I,K)-A(IP,K)*A(I,KP) |
| 30 | 2 CONTINUE |
| 31 | B(I)=B(I)-B(IP)*A(I,KP) |
| 32 | ENDIF |
| 33 | 3 CONTINUE |
| 34 | DO 4 K = 1,N |
| 35 | IF(K .NE. KP) THEN |
| 36 | C(K)=C(K)-A(IP,K)*C(KP) |
| 37 | A(IP,K)=-A(IP,K)*A(IP,KP) |
| 38 | ENDIF |
| 39 | 4 CONTINUE |
| 40 | Z=Z-B(IP)*C(KP) |
| 41 | B(IP)=-B(IP)*A(IP,KP) |
| 42 | |
| 43 | EPS=0 |
| 44 | DO 5 I = 1,M |
| 45 | DO 5 K = 1,N |
| 46 | 5 EPS=EPS+ABS(A(I,K)) |
| 47 | EPSL=LOG10(2*EPS/(M*N)) |
| 48 | IEXP=INT(EPSL)-IE0 |
| 49 | IF(EPSL .LT. 0) IEXP=IEXP-1 |
| 50 | EPS=R10**IEXP |
| 51 | |
| 52 | DO 10 I = 1,M |
| 53 | IF(ABS(B(I)) .LT. EPS) B(I)=0 |
| 54 | DO 10 K = 1,N |
| 55 | IF(ABS(A(I,K)) .LT. EPS) A(I,K)=0 |
| 56 | 10 CONTINUE |
| 57 | DO 25 K = 1,N |
| 58 | IF(ABS(C(K)) .LT. EPS) C(K)=0 |
| 59 | 25 CONTINUE |
| 60 | IF(ABS(Z) .LT. EPS) Z=0 |
| 61 | IR=LW(IP,4) |
| 62 | LW(IP,4)=LW(KP,5) |
| 63 | LW(KP,5)=IR |
| 64 | RETURN |
| 65 | END |
git://git.uio.no / u / mrichter / AliRoot.git / blame