# Category : Miscellaneous Language Source Code

Archive : FORTRN77.ZIP

Filename : RANK.FOR

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

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

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

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/