Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/transp/transp.for
There are 2 other files named transp.for in the archive. Click here to see a list.
C THIS PROGRAM SOLVES THE TRANSPORTATION PROBLEM BY THE MODI METHOD
C DESCRIBED IN HADLEY'S LINEAR PROGRAMMING!.
C **** *** ********* ******* ******** ******** *****
C **** *** ********* ******* ******** ******** *****
C **** *** ********* ******* ******** ******** *****
C THE INITIAL BASIC FEASIBLE SOLUTION IS CREATED BY THE ROW
C METHOD USING THE MINIMUM COST IN THE ROW TO CREATE THE NECESSARY
C ENTRIES ON THE BASIS.
C THE PROGRAM WILL AUTOMATICALLY CREATE THE NECESSARY ROW SLACK OR
C COLUMN SLACK AT ZERO COST TO ACCOUNT FOR INEQUALITY IN SUPPLY
C AND DESTINATION
C **** * * * * * * * * * * ********
C **** * * * * * * * * * * ********
C***********************************************************************
C WESTERN MICHIGAN UNIVERSITY
C TRANSP.FOR (FILE NAME ON LIBRARY DECTAPE)
C TRANSP, 2.2.3 (CALLING NAME, SUBLST. NO.)
C LARGE SCALE TRANSPORTATION PROBLEM (SHARE 360D - 15.2, 099)
C ADAPTED FROM AN IBM PROGRAM BY BERENICE GAN HOUCHARD
C LATER MODIFIED BY BOBBY HUNG.
C LIBRARY DECTAPE PROGS. USED: USAGE.MAC
C FORWMU PROGS. USED: TTYPTY, DEVCHR, EXISTS, EXIST, GES,
C GETPPN, JOBNUM, PRINTS, RUNUUO
C APLB10 PROGS. USED: IO, GETFOR
C INTERNAL SUBR. USED: IBAS1
C INTERNAL FUNCTIONS USED: IBAS, ICOST
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
C
C LIMITATIONS:
C
C (1) NUMBER OF ORIGIN POINTS IS AT MOST 19
C (2) NUMBER OF DESTINATION POINTS IS AT MOST 199
C (3) AT MOST 3 LINES IF OBJECT TIME FORMAT IS USED
C (4) ONLY I-TYPE FORMAT ALLOWED
C
C***********************************************************************
C***********************************************************************
C
COMMON /TSP1/ IIBAS(220),IJBAS(220),IVBAS(220),ICOS1(200),
1 IU(20),IV(200),IU1(20),IV1(200)
COMMON /TSP2/ NN, IND1, IND, NDEST
COMMON /TSPIO/ INP, IOUT, NTF
COMMON /INIO/ IFTR,IFTW,DEVN(30),FILNM(30),IPP(30),DEST(30)
DOUBLE PRECISION IFLNMI,IFLNMO,DEVNAM,FILNM,DEVN
COMMON/IOB/LEF,IRT,IALT,MPG,IPAGE,IPAGCT,IDLG,ICC,II,OUTDV
EQUIVALENCE(IORIG(1),INET1(1)),(IDEST(1),INET2(1)),(IU(1),INET(1))
C---------------TITLE CONTAINS USER SPEC. HEADING FOR OUTPUT. NOTF
C--------------- CONTAINS USER SPEC. FORMAT FOR OBJ. TIME FORMAT.
DIMENSION IORIG(20),INET1(20),IDEST(200),INET2(200),INET(442)
DIMENSION NOTF(48), TITLE(16)
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 DATA
C ITS LOGICAL NUMBER IS DETERMINED BY SUBROUTINE IO
C IOUT--DEVICE USED TO WRITE REPORT
C ITS LOGICAL NUMBER IS DETERMINED BY SUBROUTINE IO
C NTF---DEVICE USED TO CREATE AND ACCESS A TEMPORARY FILE
C***********************************************************************
C
IDLG=-1
ICC=-4
INP=2
IOUT=3
NTF=20
IPAGCT = -1
C
C***********************************************************************
C CALL SUBROUTINE USAGE AND ADD 1 TO LIBRARY PROGRAM USAGE
C***********************************************************************
C
C CALL USAGE('TRANSP')
C
C***********************************************************************
C DETERMINE IF JOB IS ON TELETYPE OR PSEUDO-TELETYPE
C IF ICODE = 0 JOB IS ON TELETYPE
C = -1 JOB IS ON PSEUDO-TELETYPE
C**********************************************************************
C
C---------------ICODE RETURNED.
CALL TTYPTY(ICODE)
C
C***********************************************************************
C GATHER INPUT/OUTPUT INFORMATION, OUTPUT OPTION AVAILABLE ONLY
C ONCE IN THE PROGRAM
C**********************************************************************
C
C--------------- 1, O, OUT, INP ARE INPUT. DEVNAM, IDVO, IDVI,
C--------------- IFLNMO, IFLNMI, IPJ, IPG, ARE RETURNED.
C--------------- 1 MEANS OUTPUT. 0 MEANS INPUT.
CALL IO(1,IOUT,DEVNAM,IDVO,IFLNMO,IPJ,IPG,IBNK)
99998 CALL IO(0,INP,DEVNAM,IDVI,IFLNMI,IPG,IPG,IBNK)
C
C***********************************************************************
C FORMAT SUBROUTINE, ITYPE = 1 MEANS ONLY I-TYPE FORMAT ALLOWED
C**********************************************************************
C
ITYPE=1
C---------------NOTF, ISTD RETURNED; OTHER ARGS ARE INPUT.
C--------------- 48=NO. OF OBJ. TIME FORMAT WORDS (3 LINES).
CALL GETFOR(IDLG,ICC,NOTF,ISTD,48,ITYPE)
C
C***********************************************************************
C ADJUST FORMAT IF NECESSARY, GATHER OTHER INPUT INFORMATION
C***********************************************************************
C
IF (ISTD.NE.1) GO TO 3996
NOTF(1)='(10I)'
DO 3995 I=2,48
3995 NOTF(I)=' '
3996 WRITE(IDLG,4000)
4000 FORMAT(' ENTER HEADER'/)
READ(ICC,10) TITLE
10 FORMAT(16A5)
3994 WRITE(IDLG,4001)
4001 FORMAT(1X,'ENTER NUMBER OF ORIGINS AND NUMBER OF DESTINATIONS'/
11X,'SEPARATE THEM BY COMMA--'$)
1111 READ(ICC,1)NORIG,NDEST
1 FORMAT(10I)
IF ((NORIG.GT.0).AND.(NDEST.GT.0)) GO TO 4002
4004 WRITE(IDLG,4003)
4003 FORMAT(1X,'ERROR IN INPUT DATA FOR ORIGIN AND DESTINATION
1 POINTS'/)
IF (ICODE.GE.0) GO TO 3994
3993 CALL EXIT
4002 IF ((NORIG.GT.19).OR.(NDEST.GT.199)) GO TO 4004
NCOST = NORIG * NDEST
1121 K1=1.E8
K2=1.E9
NDEST1=NDEST
NORIG1=NORIG
4060 WRITE(IDLG,4005)
4005 FORMAT(1X,'ENTER THE AVAILABILITIES FOR THE ORIGIN POINTS'/)
WRITE(IDLG,4006)
4006 FORMAT('+10 NUMBERS PER LINE, SEPARATED BY COMMAS'/)
1131 READ(ICC,1)(IORIG(I),I=1,NORIG)
WRITE(IDLG,4007)
4007 FORMAT(1X,'ENTER REQUIREMENTS FOR THE DESTINATION POINTS'/)
WRITE(IDLG,4006)
1141 READ(ICC,1)(IDEST(I),I=1,NDEST)
1171 ISUMO=0
ISUMD=0
DO 102 I=1,NORIG
102 ISUMO=ISUMO+IORIG(I)
DO 103 J=1,NDEST
103 ISUMD=ISUMD+IDEST(J)
1181 IF(ISUMO-ISUMD)1115,1112,1191
1191 NDEST=NDEST+1
IDEST(NDEST)=ISUMO-ISUMD
INDY=3
GO TO 9876
1115 NORIG=NORIG+1
IORIG(NORIG)=ISUMD-ISUMO
INDY=1
GO TO 9876
1112 INDY=2
9876 NN=NORIG+NDEST
DO 106 I=1,NN
IIBAS(I)=0
IJBAS(I)=0
106 IVBAS(I)=0
IF (IDVI.EQ.'TTY') GO TO 42010
WRITE(IDLG,42011)
42011 FORMAT(' PLEASE WAIT, YOUR DATA IS BEING PROCESSED'/)
GO TO 4200
42010 WRITE(IDLG,4201)
4201 FORMAT(1X,'COST: ENTER TRANSPORTATION COST PER UNIT
1 SORTED INTO DESTINATION'/)
IF (ISTD.EQ.1) WRITE(IDLG,4006)
4200 DO 105 I=1,NORIG1
IF (IDVI.EQ.'DSK') GO TO 4203
WRITE(IDLG,4202) I
4202 FORMAT(/' FOR ORIGIN',I3/)
4203 READ(INP,NOTF)(ICOS1(J),J=1,NDEST1)
GO TO (3300,3300,3302),INDY
3302 ICOS1(NDEST)=0
3300 WRITE(NTF) (ICOS1(J),J=1,NDEST)
105 CONTINUE
GO TO (3301,1122,1122),INDY
3301 DO 104 I=1,NDEST
104 ICOS1(I)=0
WRITE(NTF) (ICOS1(I),I=1,NDEST)
1122 NCOL=1
REWIND NTF
NROW=1
ISAV=K1
DO 107 I=1,NORIG
107 IU(I)=1
DO 108 J=1,NDEST
108 IV(J)=1
1142 IF(ICOST(NROW,NCOL)-ISAV)1152,1143,1143
1143 NCOL=NCOL+1
1133 IF(NCOL-NDEST)1142,1142,1163
1152 IF(IV(NCOL)-1)1143,1162,1143
1162 ISAV=ICOST(NROW,NCOL)
NCOL1=NCOL
GO TO 1143
1163 IF(IORIG(NROW)-IDEST(NCOL1))1114,1173,1164
1114 ISET=IORIG(NROW)+K1
CALL IBAS1(NROW,NCOL1,ISET )
1124 IDEST(NCOL1)=IDEST(NCOL1)-IORIG(NROW)
GO TO 1165
1173 ISET=IORIG(NROW)+K1
CALL IBAS1(NROW,NCOL1,ISET)
IV(NCOL1)=0
NCOL=1
ISAV=K1
IF(NROW-NORIG)1183,1211,1211
1183 IF(ICOST(NROW,NCOL)-ISAV)1193,1182,1182
1193 IF(IV(NCOL)-1)1182,1103,1182
1103 ISAV=ICOST(NROW,NCOL)
NCOL1=NCOL
1182 NCOL=NCOL+1
IF(NCOL-NDEST)1183,1183,1174
1174 CALL IBAS1(NROW,NCOL1,K1)
1165 NROW=NROW+1
1184 IF(NROW-NORIG)1194,1194,1211
1194 NCOL=1
ISAV=K1
GO TO 1142
1164 ISET=IDEST(NCOL1)+K1
CALL IBAS1(NROW,NCOL1,ISET)
IORIG(NROW)=IORIG(NROW)-IDEST(NCOL1)
IV(NCOL1)=0
GO TO 1194
C NOW THAT A BASIC FEASIBLE SOLUTION HAS BEEN DETERMINED IT IS NECES
C TO CALCULATE THE SHADOW COSTS AND THE (Z(J)-C(I,J)) GREATER THAN Z
C TO DETERMINE WHETHER THE SOLUTION IS OPTIMAL NNO ZNJE-NNI,JEGREATE
C THAN ZEROE. IF NON-OPTIMAL THE NEW ELEMENT IS THE ONE WITH THE
C LARGEST Z-C. IF OPTIMALITY EXISTS THE PROGRAM EXITS TO THE
C OUTPUT ROUTINE.
1211 DO 109 I=1,NORIG
IU(I)=0
109 IU1(I)=0
DO 110 J=1,NDEST
IV(J)=0
110 IV1(J)=0
1221 IU1(1)=1
NROW=1
NCOL=1
1231 IF(IBAS(NROW,NCOL)-K1)1232,1241,1241
1241 IV(NCOL)=ICOST(NROW,NCOL)-IU(NROW)
IV1(NCOL)=1
1232 NCOL=NCOL+1
1242 IF(NCOL-NDEST)1231,1231,1252
1252 NROW=NROW+1
1262 IF(NROW-NORIG)1272,1272,1261
1272 IF(IU1(NROW)-1)1282,1252,1282
1282 NCOL=1
1292 IF(IBAS(NROW,NCOL)-K1)1202,1263,1263
1202 NCOL=NCOL+1
1203 IF(NCOL-NDEST)1292,1292,1252
1263 IF(IV1(NCOL))1273,1202,1273
1273 IU(NROW)=ICOST(NROW,NCOL)-IV(NCOL)
IU1(NROW)=1
1283 NCOL=1
GO TO 1231
1261 NROW=1
1271 IF(IU1(NROW))1281,1282,1281
1281 NROW=NROW+1
1291 IF(NROW-NORIG)1271,1271,1213
1213 ISAV=0
NROW=1
1223 NCOL=1
1233 IF(IBAS(NROW,NCOL)-K1)1234,1243,1243
1243 NCOL=NCOL+1
1253 IF(NCOL-NDEST)1233,1233,1254
1254 NROW=NROW+1
1264 IF(NROW-NORIG)1223,1223,1274
1274 IF(ISAV)1311,1511,1311
1234 IS1=IU(NROW)+IV(NCOL)-ICOST(NROW,NCOL)
1244 IF(IS1-ISAV)1243,1243,1245
1245 ISAV=IS1
NROW1=NROW
NCOL1=NCOL
GO TO 1243
C THIS SECTION IS ENTERED ON EVERY NON-OPTIMAL ITERATION IT FINDS
C THIS LOOP IN THE MATRIX CONTAINING THE NEW ELEMENT AND ELEMENTS IN
C THE CURRENT BASIS. IF NO LOOP EXISTS AN ERROR MESSAGE IS PRINTED.
1311 K=(NORIG+NDEST)*2
DO 111 I=1,K
111 INET(I)=0
DO 112 I=1,NORIG
112 INET1(I)=0
DO 113 I=1,NDEST
113 INET2(I)=0
I=1
1321 INET(I)=NROW1
INET(I+1)=NCOL1
NROW=NROW1
NCOL=1
I=I+2
1331 IF(IBAS(NROW,NCOL)-K1)1332,1341,1341
1341 IF(NCOL-NCOL1)1351,1332,1351
1351 INET(I)=NROW
INET(I+1)=NCOL
I=I+2
GO TO 1313
1332 NCOL=NCOL+1
1322 IF(NCOL-NDEST)1331,1331,1312
1312 I=1
WRITE(IOUT,3)I,NROW1,NCOL1
3 FORMAT(14H ERROR NUMBER,I4,I6,I6)
GO TO 1511
1313 INET2(NCOL)=1
NROW=1
1323 IF(IBAS(NROW,NCOL)-K1)1333,1324,1324
1333 NROW=NROW+1
1343 IF(NROW-NORIG)1323,1323,1353
1353 I=I-2
1363 IF(I)1315,1315,1373
1373 NROW=INET(I)
NCOL=INET(I+1)
INET2(NCOL)=0
GO TO 1375
1315 I=2
WRITE(IOUT,3)I,NROW1,NCOL1
GO TO 1511
1324 IF(NROW-INET(I-2))1334,1333,1334
1334 IF(INET1(NROW))1353,1344,1353
1344 INET(I)=NROW
INET(I+1)=NCOL
I=I+2
1354 IF(NROW-NROW1)1364,1355,1364
1355 I=I-2
GO TO 1353
1364 INET1(NROW)=1
NCOL=1
1374 IF(IBAS(NROW,NCOL)-K1)1375,1384,1384
1375 NCOL=NCOL+1
1365 IF(NCOL-NDEST)1374,1374,1371
1384 IF(NCOL-INET(I-1))1394,1375,1394
1394 IF(INET2(NCOL))1371,1395,1371
1395 INET(I)=NROW
INET(I+1)=NCOL
I=I+2
1305 IF(NCOL-NCOL1)1313,1411,1313
1371 I=I-2
1381 IF(I)1315,1315,1382
1382 NROW=INET(I)
NCOL=INET(I+1)
INET1(NROW)=0
GO TO 1333
C AT THIS TIME WE HAVE FOUND A VALID LOOP IN WHICH ALL MOVES ARE
C ORTHOGONAL AND SHALL NOW FIND THE SMALLEST ELEMENT IN THE LOOP
C WHICH IS REACHED IN AN ODD NUMBER OR MOVES FROM THE ENTERING
C ELEMENT. THIS IS THE ELEMENT WHICH WILL LEAVE.
1411 I=3
ISAV=K2
1421 NROW=INET(I)
NCOL=INET(I+1)
1431 IF(IBAS(NROW,NCOL)-ISAV)1432,1441,1441
1432 ISAV=IBAS(NROW,NCOL)
NROW2=NROW
NCOL2=NCOL
1441 IF(NCOL-NCOL1)1451,1442,1451
1451 I=I+4
1461 IF(I-K)1421,1421,1471
1471 I=3
WRITE(IOUT,3)I,NROW1,NCOL1
GO TO 1511
1442 IF(ISAV-K2)1443,1452,1452
1452 I=4
WRITE(IOUT,3)I,NROW1,NCOL1
GO TO 1511
1443 J=-1
NROW=INET(1)
NCOL=INET(2)
CALL IBAS1(NROW,NCOL,ISAV)
ISAV=ISAV-K1
I=3
1444 NROW=INET(I)
NCOL=INET(I+1)
1453 IF(NROW-NROW2)1463,1454,1463
1454 IF(NCOL-NCOL2)1463,1455,1463
1455 CALL IBAS1(NROW,NCOL,0)
GO TO 1473
1463 ISET=IBAS(NROW,NCOL) +J*ISAV
CALL IBAS1(NROW,NCOL,ISET)
1473 J=-J
I=I+2
1483 IF(NCOL-NCOL1)1444,1211,1444
C THE NEXT ROUTINE IS THE OUTPUT ROUTINE. IT IS REACHED EITHER WHEN
C AN OPTIMUM SOLUTION IS FOUND OR WHEN AN ERROR OCCURS AND THE OUTPU
C MAYBE OF INTEREST. IN CASE OF AN ERROR THE SHADOW PRICES REPRESENT
C COORDINATES OF THE BASIS LOOP CALCULATIONS
1511 DO 4070 I=1,16
IF (TITLE(I).NE.' ') GO TO 4071
4070 CONTINUE
WRITE(IOUT,4073)
4073 FORMAT(1H1)
GO TO 4062
4071 WRITE(IOUT,11) TITLE
11 FORMAT(1H1,16A5)
4062 WRITE(IOUT,4)
4 FORMAT(1H-22HORIGIN SHADOW PRICE)
1521 WRITE(IOUT,5)(I,IU(I),I=1,NORIG1)
5 FORMAT(1H I6,I14)
1531 WRITE(IOUT,6)
6 FORMAT(23H-DESTIN SHADOW PRICE)
1541 WRITE(IOUT,5)(J,IV(J),J=1,NDEST1)
WRITE(IOUT,15)
15 FORMAT(1H-,'FINAL ALLOCATION SORTED BY SUPPLY POINTS'///)
1551 WRITE(IOUT,7)
7 FORMAT(49H0ORIGIN DESTIN QUANTITY UNIT COST COST)
II19=0
1561 DO 200 I=1,NORIG1
ISUM = 0
ISUM2 = 0
DO 114 J=1,NDEST1
IF(IBAS(I,J)-K1)114,115,115
115 ITEM=IBAS(I,J)-K1
ITEM1=ICOST(I,J)
ITEM2=ITEM*ITEM1
WRITE(IOUT,8)I,J,ITEM,ITEM1,ITEM2
8 FORMAT(1H ,I6,I9,I10,I12,I12,2X)
ISUM = ISUM + ITEM
ISUM2 = ISUM2 + ITEM2
114 CONTINUE
WRITE(IOUT,17) ISUM,ISUM2
17 FORMAT(1X,49(1H-)/ 1X,'TOTAL',10X,I10,12X,I12//)
II19=II19+ISUM2
200 CONTINUE
WRITE(IOUT,9999) II19
9999 FORMAT(1X,49(1H=)//// 1X,'TOTAL COST =',I9)
IND=0
IND1=0
INDY=1
REWIND NTF
C
C***********************************************************************
C END OF ONE DATA SET, BRANCH BACK AND DETERMINE IF MORE DATA
C IS TO BE ANALYZED
C***********************************************************************
C
WRITE(IDLG,99997)
99997 FORMAT('-')
GO TO 99998
END
C---------------M, N ARE INPUT. IIBAS, IJBAS, IVBAS ARE INPUT THRU
C--------------- COMMON /TSP1/. IND1 IS INPUT THRU COMMON /TSP2/.
FUNCTION IBAS(M,N)
C
COMMON/TSP1/ IIBAS(220),IJBAS(220),IVBAS(220),ICOS1(200),
1 IU(20),IV(200),IU1(20),IV1(200)
COMMON /TSP2/ NN,IND1,IND,NDEST
1 DO 99 I=1,IND1
IF(IIBAS(I)-M)99,98,99
98 IF(IJBAS(I)-N)99,97,99
97 IBAS=IVBAS(I)
RETURN
99 CONTINUE
IBAS=0
RETURN
END
C---------------M, N ARE INPUT. ICOS1 IS RETURNED THRU COMMON
C--------------- /TSP1/. NTF IS INPUT THRU COMMON /TSPIO/. NDEST,
C--------------- IND ARE INPUT THRU COMMON /TSP2/. IND IS MODIFIED.
FUNCTION ICOST(M,N)
COMMON/TSP1/ IIBAS(220),IJBAS(220),IVBAS(220),ICOS1(200),
1 IU(20),IV(200),IU1(20),IV1(200)
COMMON/TSP2/ NN,IND1,IND,NDEST
COMMON /TSPIO/ INP, IOUT, NTF
C
99 IF(IND-M)1,2,3
1 READ(NTF) (ICOS1(I),I=1,NDEST)
IND=IND+1
GO TO 99
3 IND=0
REWIND NTF
GO TO 99
2 ICOST=ICOS1(N)
RETURN
END
C---------------ALL ARGS. ARE INPUT. IIBAS, IJBAS ARE INPUT THRU
C--------------- COMMON /TSP1/. IVBAS IS RETURNED THRU COMMON /TSP1/.
C--------------- NN, IND1 ARE INPUT THRU COMMON /TSP2/. IOUT IS
C--------------- INPUT THRU COMMON /TSPIO/.
SUBROUTINE IBAS1(M,N,IVAL)
C
COMMON/TSP1/ IIBAS(220),IJBAS(220),IVBAS(220),ICOS1(200),
1 IU(20),IV(200),IU1(20),IV1(200)
COMMON/TSP2/ NN,IND1,IND,NDEST
COMMON /TSPIO/ INP, IOUT, NTF
C
IF(IND1)1,999,1
1 DO 99 I=1,IND1
IF(IIBAS(I)-M)99,98,99
98 IF(IJBAS(I)-N)99,97,99
97 IVBAS(I)=IVAL
IF(IVAL)96,95,96
96 RETURN
95 I1=I+1
DO 94 J=I1,IND1
IIBAS(J-1)=IIBAS(J)
IJBAS(J-1)=IJBAS(J)
94 IVBAS(J-1)=IVBAS(J)
IIBAS(IND1)=0
IJBAS(IND1)=0
IND1=IND1-1
RETURN
99 CONTINUE
999 IND1=IND1+1
IF(IND1-NN)93,93,92
92 WRITE(IOUT,91)
91 FORMAT(' PROGRAM ERROR ')
CALL EXIT
93 IIBAS(IND1)=M
IJBAS(IND1)=N
IVBAS(IND1)=IVAL
RETURN
END