Changes needed by ICC/IFC compiler (Intel)
[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / h / h101s2.F
CommitLineData
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 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
16C Finds the pivot-column, by taking degeneracy into account.
17C 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
36C KP = 0 : No column found.
37C 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
58C 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
68C 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