PDP-10 Archive: 43,50466/assign.f4 from decuslib10-09

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/assign.f4
There are no other files named assign.f4 in the archive.
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	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
	IF (ISTD.NE.1) GO TO 305
	NOTF(1)='(20F)'
	DO 304 I=2,48
304	NOTF(I)=' '
	IF (IO2.NE.'TTY') GO TO 307
	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