Category : Miscellaneous Language Source Code
Archive   : FORTRN77.ZIP
Filename : RANK.FOR

 
Output of file : RANK.FOR contained in archive : FORTRN77.ZIP
SUBROUTINE RANK(MR,NR,NC,NCC,A,ZMCH,CONS,NRANK,IERR,LP,MP)
C
C PURPOSE...SOLUTION OF MA EQUATIONS IN N UNKNOWNS.
C
DIMENSION A(1), LP(1), MP(1)
IF(NR.GT.MR) GO TO 210
IF(NCC.GT.MR) GO TO 210
MTX = MR*NC
MRA = MR + 1
MRS = MR - 1
MDN = MR - NR
MTR = MTX - MDN
MTRA = MTX + 1
NY = MIN0(NR,NC)
NRANK = 0
IERR = 0
NRS = NR - 1
DO 2 I = 1,NR
MP(I) = I
2 CONTINUE
DO 1 I = 1,NC
LP(I) = I
1 CONTINUE
NTC = NC + NCC
MTT = MR*NTC - MDN
IX = NR
DO 70 I = 1,NY
IS = I - 1
II = MR * IS + I
IISB = II - 1
IIAD = II + MR
ICS = MR*I - MRS
ICF = ICS + IX - 1
IIA = II + 1
3 TEMP = 0.
DO 31 J = II, MTT,MR
IF(I.EQ.1) GO TO 33
KF = J - 1
KS = J - I + 1
KX = I
DO 30 K = KS,KF
A(J) = A(J) - A(KX)*A(K)
KX = KX + MR
30 CONTINUE
33 IF(J.GT.MTR) GO TO 31
IF(ABS(A(J)).LE.TEMP) GO TO 31
TEMP = ABS(A(J))
NX = J/MR + 1
31 CONTINUE
IF(I.EQ.NC) GO TO 35
IF(NX.EQ.I) GO TO 35
ITEMP = LP(NX)
LP(NX) = LP(I)
LP(I) = ITEMP
LPIS = MR*NX - MRS
DO 34 K = ICS,ICF
TEMP = A(K)
A(K) = A(LPIS)
A(LPIS) = TEMP
LPIS = LPIS + 1
34 CONTINUE
35 IF(ZMCH - ABS(A(II))) 45,45,10
MTXI = MTX + I
10 IF(NCC.EQ.0) GO TO 12
DO 11 J = MTXI,MTT,MR
IF(ABS(A(J)).LE.CONS) GO TO 72
MP(I) = 0 - IABS(MP(I))
A(J) = MP(I)
IERR = 1
GO TO 11
72 A(J) = IABS(MP(I))
11 CONTINUE
IF(MP(I).GT.0) MP(I) = 0
12 IF(I.EQ.IX) GO TO 78
ITEMP = MP(I)
MP(I) = MP(IX)
MP(IX) = ITEMP
K = I
DO 14 J = IX,MTT,MR
TEMP = A(K)
A(K) = A(J)
A(J) = TEMP
K = K + MR
14 CONTINUE
IX = IX - 1
GO TO 3
45 NRANK = NRANK + 1
DO 46 J = IIAD,MTT,MR
A(J) = A(J)/A(II)
46 CONTINUE
IF(I.EQ.1) GO TO 70
IF(I.EQ.IX) GO TO 78
DO 47 M = IIA,ICF
KX = M - ICS + 1
DO 48 KY = ICS,IISB
A(M) = A(M) - A(KX) * A(KY)
KX = KX + MR
48 CONTINUE
47 CONTINUE
70 CONTINUE
IF(NCC.EQ.0) RETURN
NRANKA = NRANK + 1
DO 15 I = NRANKA,IX
IA = I + MTX
DO 16 J = IA,MTT,MR
KY = J - I + 1
DO 17 KX = I,MTR,MR
A(J) = A(J) - A(KX)*A(KY)
KY = KY + 1
17 CONTINUE
IF(ABS(A(J)).LE.CONS) GO TO 71
MP(I) = 0 - IABS(MP(I))
A(J) = MP(I)
IERR = 1
GO TO 16
71 A(J) = IABS(MP(I))
16 CONTINUE
IF(MP(I).GT.0) MP(I) = 0
15 CONTINUE
78 IF(NCC.EQ.0) RETURN
NRTAD = MTX + NRANK
NRANKS = NRANK - 1
NFIN = MR*(NC - NRANK)
NTR = MTR - NFIN
DO 180 I = 1,NRANKS
IREV = NRTAD - I
KRS = IREV - MR*I - NFIN
DO 170 IRCNT = IREV,MTT,MR
KCS = IRCNT + 1
DO 160 K = KRS,NTR,MR
A(IRCNT) = A(IRCNT) - A(KCS)*A(K)
KCS = KCS + 1
160 CONTINUE
170 CONTINUE
180 CONTINUE
DO 6 I = 1,NC
ICS = MR*LP(I) - MRS
ICF = ICS + NCC - 1
K = MTX + I - MR
DO 7 J = ICS,ICF
K = K + MR
IF(I.GT.NRANK) GO TO 8
A(J) = A(K)
A(K) = MP(I)
GO TO 7
8 A(J) = 0
7 CONTINUE
6 CONTINUE
DO 61 I = 1,NRS
MTXI = MTX + I
62 IX = IABS(INT(A(MTXI)))
IF(IX.EQ.I) GO TO 61
ITEMP = MP(I)
MP(I) = MP(IX)
MP(IX) = ITEMP
J = MTX + IX
DO 63 K = MTXI,MTT,MR
TEMP = A(K)
A(K) = A(J)
A(J) = TEMP
J = J + MR
63 CONTINUE
GO TO 62
61 CONTINUE
IF(NRANK.EQ.NC) GO TO 22
NRANKA = NRANK + 1
DO 21 I = NRANKA,NC
21 LP(I) = -LP(I)
22 NCS = NC - 1
DO 9 I = 1,NCS
20 IF (IABS(LP(I)).EQ.I) GO TO 9
IX = IABS(LP(I))
ITEMP = LP(I)
LP(I) = LP(IX)
LP(IX) = ITEMP
GO TO 20
9 CONTINUE
RETURN
210 IERR = 2
RETURN
END



  3 Responses to “Category : Miscellaneous Language Source Code
Archive   : FORTRN77.ZIP
Filename : RANK.FOR

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/