Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/assign/assign.for
There are 3 other files named assign.for in the archive. Click here to see a list.
C WESTERN MICHIGAN UNIVERSITY
C ASSIGN.F4 (FILE NAME ON LIBRARY DECTAPE)
C ASSIGN, 2.2.2 (CALLING NAME, SUBLST NO.)
C ASSIGNMENT PROGBLEM (RECTANGULAR MATRICES)
C REPRINTING PRIVILEGES WERE GRANTED BY PERMISSION OF THE
C ASSOCIATION FOR COMPUTING MACHINERY BUT NOT FOR PROFIT.
C THIS PROGRAM IS A FORTRAN IV VERSION OF AN ALGOL PROGRAM
C PUBLISHED IN THE DECEMBER 1971 ISSUE OF THE COMMUNICATIONS
C OF THE ACM, PAGES 805--806. THE AUTHORS OF THE ORIGINAL
C PROGRAM ARE PRANCIOS BOURGEOIS AND JEAN-CLAUDE LASALLE
C OF CERN, GENEVA, SWITZERLAND.
C THE FORTRAN PROGRAMMING WAS DONE BY BERENICE GAN HOUCHARD
C LIBRARY DECTAPE PROGS. USED: USAGE.MAC
C FORWMU PROGS. USED: TTYPTY, DEVCHG, EXISTS, POINTS
C APLIB PROGS. USED: IO, GETFOR
C INTERNAL SUBR. USED: ALGO
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
c Modified slightly at statement label 304 (roughly); explanation there.
c By Paul T. Robinson, Wesleyan Univ, 18 Oct 1980
c
C LIMITATIONS:
C
C (1) MAXIMUM SIZE OF MATRIX IS 100 BY 100
C (2) AT MOST 3 LINES IF OBJECT TIME FORMAT IS USED
C (3) ONLY F-TYPE FORMAT IS ALLOWED
C
C*********************************************************************
C
C---------------ID HAS IDENT. FOR OUTPUT. NOTF CONTAINS USER
C--------------- SPEC. FORMAT. A CONTAINS TABLEAUX. X CONTAINS
C--------------- ANSWERS. IDUM CONTAINS INDICES AND ASSOC. ANSWERS.
DIMENSION A(100,100),X(100),IDUM(100,2),ID(16),NOTF(48)
EQUIVALENCE(A,IDUM)
INTEGER X
DATA LEFT,LRT/'(',')'/
C
C***********************************************************************
C DEVICES USED:
C
C IDLG--DEVICE USED TO COMMUNICATE WITH USER
C IT IS ALWAYS SET TO -1
C ICC---DEVICE USED TO ACCEPT USER'S RESPONSES
C IT IS ALWAYS SET TO -4
C INP---DEVICE USED TO READ THE DATA
C ITS LOGICAL NUMBER IS DETERMINED BY SUBROUTINE IO
C IOUT--DEVICE USED TO WRITE OUT THE REPORT
C ITS LOGICAL NUMBER IS DETERMINED BY SUBROUTINE IO
C
C***********************************************************************
C
IDLG=-1
ICC=-4
INP=2
IOUT=3
C
C***********************************************************************
C CALL SUBROUTINE USAGE AND ADD 1 TO PROGRAM USAGE
C***********************************************************************
C
C CALL USAGE('ASSIGN')
C
C***********************************************************************
C DETERMINE IF JOB IS ON TELETYPE OF PSEUDO-TELETYPE
C IF ICODE = 0 JOB IS ON TELETYPE
C = -1 JOB IS ON PSEUDO-TELETYPE
***********************************************************************
C
C---------------ICODE RETURNED
CALL TTYPTY(ICODE)
C
C***********************************************************************
C GATHER INPUT/OUTPUT INFORMATION, OUTPUT OPTION IS AVAILABLE ONLY
C ONCE IN THE PROGRAM
C***********************************************************************
C
C---------------IO3, IO2 ARE RETURNED, OTHER ARGS. ARE INPUT.
C--------------- 1 CAUSES OUTPUT? TO PRINT, 0 CAUSES INPUT? TO PRINT.
C--------------- ICODE COMES FROM CALL TTYPTY.
CALL IO(IOUT,IO3,ICC,IDLG,1,ICODE)
301 CALL IO(INP,IO2,ICC,IDLG,0,ICODE)
C
C***********************************************************************
C FORMAT SUBROUTINE, ITYPE=2 MEANS ONLY F-TYPE FORMAT ALLOWED
C***********************************************************************
C
ITYPE=2
C---------------NOTF, ISTD ARE RETURNED. OTHER ARGS. ARE INPUT.
C--------------- 48= NO. OF FMT. WORDS FOR OBJ. TIME FORMAT.
CALL GETFOR(IDLG,ICC,NOTF,ISTD,48,ITYPE)
C
C***********************************************************************
C GATHER OTHER INPUT INFORMATION
C***********************************************************************
C
WRITE(IDLG,302)
302 FORMAT(' ENTER HEADER'/)
READ(ICC,303),ID
303 FORMAT(16A5)
110 WRITE(IDLG,11)
11 FORMAT(' MAXIMUM SIZE OF MATRIX IS 100 BY 100')
10 WRITE(IDLG,12)
12 FORMAT(' ENTER MATRIX SIZE: ROW,COLUMN--'$)
READ(INP,1) N,M
1 FORMAT(2I)
IF ((N.GT.0).AND.(M.GT.0)) GO TO 200
202 WRITE(IDLG,201)
201 FORMAT(' MATRIX SIZE NOT WITHIN RANGE, TRY AGAIN'/)
GO TO 110
200 IF ((N.GT.100).OR.(M.GT.100)) GO TO 202
C
C***********************************************************************
C ADJUST FORMAT IF NECESSARY, START READ AND ALGORITHM ROUTINES
C***********************************************************************
C
c Follwing was IF(...) GO TO 305 which confused the compiler.
c Modified to give what looked like the desired effect.
c Paul T. Robinson, Wesleyan Univ, 18 Oct 1980
IF (ISTD.NE.1) GO TO 3040
NOTF(1)='(20F)'
DO 304 I=2,48
304 NOTF(I)=' '
IF (IO2.NE.'TTY') GO TO 307
3040 WRITE(IDLG,305)
305 FORMAT(' ENTER THE MATRIX'/)
IF (ISTD.EQ.1) WRITE(IDLG,306)
306 FORMAT('+(AT MOST 20 NUMBERS PER LINE, SEPARATED BY COMMAS)'/)
GO TO 230
307 WRITE(IDLG,308)
308 FORMAT(' PLEASE WAIT, YOUR DATA IS BEING PROCESSED'/)
230 DO 2 I=1,N
2 READ(INP,NOTF)(A(I,J),J=1,M)
CALL ALGO(A,N,M,TOTAL,X)
C
C***********************************************************************
C START OF REPORT
C***********************************************************************
C
WRITE(IOUT,220)
220 FORMAT(1H1)
DO 221 I=1,16
IF (ID(I).NE.' ') GO TO 223
221 CONTINUE
GO TO 222
223 WRITE(IOUT,224) ID
224 FORMAT(1X,16A5)
222 J=1
DO 401 I=1,N
IF (X(I).EQ.0) GO TO 401
IDUM(J,1)=I
IDUM(J,2)=X(I)
J=J+1
401 CONTINUE
J=MIN0(N,M)
WRITE(IOUT,403)
403 FORMAT(' INDICES:')
402 WRITE(IOUT,41),(LEFT,IDUM(I,1),IDUM(I,2),LRT,I=1,J)
41 FORMAT(5(1X,A1,I3,',',I3,A1,4X))
WRITE(IOUT,50), TOTAL
50 FORMAT(/' SUM=',G)
C
C***********************************************************************
C END OF ONE DATA SET, BRANCH BACK TO DETERMINE IF MORE DATA
C IS TO BE ANALYZED
C***********************************************************************
C
WRITE(IDLG,60)
60 FORMAT('-')
GO TO 301
END
C---------------A, N, M, ARE INPUT. TOTAL, X ARE RETURNED.
SUBROUTINE ALGO(A,N,M,TOTAL,X)
C
C THIS IS THE SUBROUTINE THAT IS CONVERTED FROM THE ALGOL
C PROGRAM MENTIONED IN THE MAIN PROGRAM. THE SUBROUTINE
C USES AN ALGORITHM FOR THE ASSIGNMENT PROBLEM TO RECTANGULAR
C MATRICES.
C
DIMENSION A(100,100),LAMBDA(100),MU(100)
INTEGER X(100),C(100),CB(100),R(100),Y(100)
INTEGER CBL,CL,CL0,RL,RS,SW,FLAG
REAL MIN
TOTAL=0
IMIN=M
IMAX=N
IF (N.GT.M) GO TO 600
IMIN=N
IMAX=M
DO 500 I=1,N
MIN=A(I,1)
DO 501 J=2,M
IF (A(I,J).LT.MIN) MIN=A(I,J)
501 CONTINUE
DO 502 J=1,M
502 A(I,J)=A(I,J)-MIN
TOTAL=TOTAL+MIN
500 CONTINUE
IF (M.GT.N) GO TO 700
C
C JA
C
600 DO 601 J=1,M
MIN=A(1,J)
DO 602 I=2,N
IF (A(I,J).LT.MIN) MIN=A(I,J)
602 CONTINUE
DO 603 I=1,N
603 A(I,J)=A(I,J)-MIN
TOTAL=TOTAL+MIN
601 CONTINUE
C
C JB
C
700 DO 701 I=1,N
701 X(I)=0
DO 702 I=1,M
702 Y(I)=0
DO 703 I=1,N
DO 704 J=1,M
IF ((A(I,J).NE.0).OR.(X(I).NE.0).OR.(Y(J).NE.0)) GO TO 704
X(I)=J
Y(J)=I
704 CONTINUE
703 CONTINUE
C
C START LABELING
C
800 FLAG=N
RL=0
CL=0
RS=1
DO 801 I=1,N
MU(I)=0
IF (X(I).NE.0) GO TO 801
RL=RL+1
R(RL)=I
MU(I)=-1
FLAG=FLAG-1
801 CONTINUE
IF (FLAG.EQ.IMIN) GO TO 999
DO 802 J=1,M
802 LAMBDA(J)=0
C
C LABEL AND SCAN
C
900 I=R(RS)
RS=RS+1
DO 901 J=1,M
IF ((A(I,J).NE.0).OR.(LAMBDA(J).NE.0)) GO TO 901
LAMBDA(J)=I
CL=CL+1
C(CL)=J
IF (Y(J).EQ.0) GO TO 400
RL=RL+1
R(RL)=Y(J)
MU(Y(J))=I
901 CONTINUE
IF (RS.LE.RL) GO TO 900
C
C RENORMALIZE
C
SW=1
CL0=CL
CBL=0
DO 910 J=1,M
IF (LAMBDA(J).NE.0) GO TO 910
CBL=CBL+1
CB(CBL)=J
910 CONTINUE
MIN=A(R(1),CB(1))
DO 920 K=1,RL
KK=R(K)
DO 921 L=1,CBL
LL=CB(L)
IF (A(KK,LL).LT.MIN) MIN=A(KK,LL)
921 CONTINUE
920 CONTINUE
TOTAL=TOTAL+MIN*(RL+CBL-IMAX)
DO 950 I=1,N
IF (MU(I).NE.0) GO TO 940
IF (CL0.LT.1) GO TO 950
DO 931 L=1,CL0
931 A(I,C(L))=A(I,C(L))+MIN
GO TO 950
940 DO 941 L=1,CBL
A(I,CB(L))=A(I,CB(L))-MIN
GO TO (100,941,300,400),SW
100 IF ((A(I,CB(L)).NE.0).OR.(LAMBDA(CB(L)).NE.0)) GO TO 941
LAMBDA(CB(L))=I
IF (Y(CB(L)).NE.0) GO TO 945
J=CB(L)
SW=2
GO TO 941
945 CL=CL+1
C(CL)=CB(L)
RL=RL+1
R(RL)=Y(CB(L))
941 CONTINUE
950 CONTINUE
IF ((SW+2)-3) 300,300,400
300 IF (CL0.EQ.CL) GO TO 900
DO 301 I=CL0+1,CL
II=C(I)
301 MU(Y(II))=II
GO TO 900
C
C MARK NEW COLUMN AND PERMUTE
C
400 I=LAMBDA(J)
Y(J)=I
IF (X(I).EQ.0) GO TO 420
K=J
J=X(I)
X(I)=K
GO TO 400
420 X(I)=J
GO TO 800
999 RETURN
END