Changes needed by ICC/IFC compiler (Intel)
[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / h / h101s2.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 H101S2(A,B,C,M,N,IDA,IP,KP,KK,LW,IDW,W,X,EPS,IRC)
11
12 #include "gen/imp64.inc"
13
14       DIMENSION A(IDA,*),B(*),C(*),X(*),W(*),LW(IDW,*)
15
16 C     Finds the pivot-column, by taking degeneracy into account.
17 C     Columns with C(K) >= 0 and A(IP,K) > 0: LW(.,3) = 1
18
19       DO 1 K = 1,N
20     1 LW(K,3)=0
21       DO 5 K = 1,N
22       IF(LW(K,2) .EQ. IRC .AND. K .NE. KK) THEN
23        IF(ABS(A(IP,K)) .LT. EPS) A(IP,K)=0
24        IF(ABS(C(K)) .LT. EPS) C(K)=0
25        IF(A(IP,K) .GT. 0 .AND. C(K) .GE. 0) THEN
26         LW(K,3)=1
27         Q=C(K)/A(IP,K)
28        ENDIF
29       ENDIF
30     5 CONTINUE
31       KP=0
32       DO 6 K = 1,N
33     6 KP=KP+LW(K,3)
34       IF(KP .EQ. 0) RETURN
35
36 C     KP = 0 : No column found.
37 C     Only columns with minimum quotient: LW(.,3) = 1.
38
39       DMIN=Q
40       DO 11 J = 1,2
41       DO 11 K = 1,N
42       IF(LW(K,3) .NE. 0) THEN
43        Q=C(K)/A(IP,K)
44        IF(Q .LE. DMIN) THEN
45         DMIN=Q
46         KP=K
47         GO TO 11
48        ENDIF
49        LW(K,3)=0
50       ENDIF
51    11 CONTINUE
52
53    12 IND=0
54       DO 15 K = 1,N
55    15 IND=IND+LW(K,3)
56       IF(IND .EQ. 1) RETURN
57
58 C     Two possible columns are picked out
59
60       KP1=0
61       DO 20 K = 1,N
62       IF(LW(K,3) .NE. 0) THEN
63        IF(KP1 .EQ. 0) KP1=K
64        KP2=K
65       ENDIF
66    20 CONTINUE
67
68 C     Choose pivot column from two columns with equal quotient.
69
70       DO 25 J = 1,M+N
71       X(J)=0
72    25 W(J)=0
73       X(LW(KP1,5))=1
74       W(LW(KP2,5))=1
75       DO 30 I = 1,M
76       IF(LW(I,1) .EQ. IRC) THEN
77        IF(ABS(A(I,KP1)) .LT. EPS) A(I,KP1)=0
78        IF(ABS(A(I,KP2)) .LT. EPS) A(I,KP2)=0
79        X(LW(I,4))=A(I,KP1)
80        W(LW(I,4))=A(I,KP2)
81       ENDIF
82    30 CONTINUE
83       DO 35 J = 1,M+N
84       IF(J .EQ. LW(IP,4)) THEN
85        X(J)=1
86        W(J)=1
87       ELSE
88        X(J)=X(J)/A(IP,KP1)
89        W(J)=W(J)/A(IP,KP2)
90       ENDIF
91    35 CONTINUE
92       DO 50 J = 1,M+N
93       IF(X(J) .LT. W(J)) THEN
94        LW(KP2,3)=0
95        KP=KP1
96        GO TO 12
97       ELSEIF(X(J) .GT. W(J)) THEN
98        LW(KP1,3)=0
99        KP=KP2
100        GO TO 12
101       ENDIF
102    50 CONTINUE
103       RETURN
104       END