This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / h / h101s1.F
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