Google
 

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