C MAIN CSK00010 C*** COMMAND DRIVER *** CSK00020 C***********************************************************************CSK00030 C HIERARCHY: CSK00040 C MAIN (GENERAL DRIVER) CSK00050 C +---CMDGET (READ AND PARSE NEXT COMMAND) CSK00060 C | | CSK00070 C | +--IPARSE (PARSE INPUT LINE) CSK00080 C | | | CSK00090 C | | +---TOKEN (TOKENIZE LINE) CSK00100 C | | +---CTI (CONVERT CHAR-TO-INTEGERS) CSK00110 C | | CSK00120 C | +--ICMD (LOOKUP COMMAND INDEX) CSK00130 C | CSK00140 C +---CMDEXE (EXECUTE COMMAND) CSK00150 C +---(ALL COMMAND ROUTINES) CSK00160 C***********************************************************************CSK00170 INTEGER CMDGET CSK00180 LOGICAL CMDEXE,IQUIT CSK00190 INCLUDE "command" CSK00200 CALL GREET CSK00210 CALL INIT CSK00220 IQUIT = .FALSE. CSK00230 C CSK00240 10 IERR = CMDGET() CSK00250 IF (IERR .EQ.0) THEN CSK00260 IQUIT = CMDEXE(TOKVAL(1)) CSK00270 ELSE IF (IERR .GT. 0) THEN CSK00280 WRITE(LUOUT,1000) CSK00290 ELSE CSK00300 WRITE (LUOUT,1100) TOK(1) CSK00310 ENDIF CSK00320 IF (.NOT.IQUIT) GOTO 10 CSK00330 C CSK00340 RETURN CSK00350 1000 FORMAT(11X,'>>Too many tokens<<') CSK00360 1100 FORMAT(11X,'>>Unknown command ',A8,'<<') CSK00370 END CSK00380 BLOCK DATA CSK00390 INCLUDE "csk" CSK00400 INCLUDE "command" CSK00410 COMMON/IGNORE/INDEX,THERE,DMPCOD CSK00420 DATA CMDNAM/'ADD','DELETE','DISPLAY','FILES','HELP', CSK00430 1 'LIST','MINIMIZE','MODEL','NODE','POSITIVE','RECORD', CSK00440 2 'RENAME','REPLACE','SAVE','SOLUTION','SOLVE','STATUS','TITLE', CSK00450 3 'QUIT'/ CSK00460 DATA NUMCMD /MAXCMD/ CSK00470 DATA STAT/' UNKNOWN',' *OPTIMAL*','INFEASIBLE'/ CSK00480 DATA LUCOM,LUOUT,LUDISK,LUMOD,LUREC/5,6,21,10,20/ CSK00490 DATA MAXN,MAXA /DIMNOD,DIMARC/, MODNAM,TITLE/' ',' '/ CSK00500 DATA LINPSC,LINPPG/22,55/, ISMODL/.FALSE./ CSK00510 DATA VERSON/2.2/ CSK00520 END CSK00530 SUBROUTINE INIT CSK00540 INCLUDE "csk" CSK00550 INCLUDE "command" CSK00560 KDUAL = 1 CSK00570 MAXA = DIMARC CSK00580 MAXN = DIMNOD - 1 CSK00590 OFFSET = MAXA CSK00600 IZZ = 0 CSK00610 CALL NEWNET CSK00620 RECON = .FALSE. CSK00630 OPENRE = .FALSE. CSK00640 CHECK = .FALSE. CSK00650 RDSKON = .FALSE. CSK00660 RDSKOP = .FALSE. CSK00670 * (OPEN RECORDING FILE) CSK00680 RETURN CSK00690 END CSK00700 SUBROUTINE ADD CSK00710 LOGICAL MORE, TOKARC, GETTOK, GETLIN CSK00720 INCLUDE "command" CSK00730 INCLUDE "csk" CSK00740 IF (.NOT.ISMODL) THEN CSK00750 WRITE(LUOUT,9000) CSK00760 STOP RETURN CSK00770 ENDIF CSK00780 CHGMOD = .TRUE. CSK00790 LININC = 1 CSK00800 CLRSC = LINPSC -3 CSK00810 LINES = LINPSC CSK00820 MORE = .TRUE. CSK00830 5 IF (MORE) THEN CSK00840 LINES = LINES + LININC CSK00850 IF (LINES .GE. CLRSC) THEN CSK00860 CALL CLRSCR CSK00870 C WRITE (LUOUT,1000) CSK00880 LINES = LININC + 1 CSK00890 ENDIF CSK00900 * WRITE (LUOUT,1000) CSK00910 MORE = GETTOK() CSK00920 IF (.NOT.MORE) THEN CSK00930 GOTO 5 CSK00940 ELSE IF (TOKARC()) THEN CSK00950 IF (TOK(1) .EQ. 'END') THEN CSK00960 MORE = .FALSE. CSK00970 ELSE CSK00980 CALL POPARC(ID) CSK00990 IF (ID.LE.0) THEN CSK01000 WRITE (LUOUT,1100) MAXA CSK01010 MORE = .FALSE. CSK01020 STOP ELSE CSK01030 IARC = ARCID(ID) CSK01040 CALL NODENO (TOK(1), IFROM(IARC)) CSK01050 CALL NODENO (TOK(2), JTO(IARC)) CSK01060 IF (IFROM(IARC).EQ.0 .OR. CSK01070 + JTO(IARC).EQ.0) THEN CSK01080 WRITE (LUOUT,1200) MAXN CSK01090 MORE = .FALSE. CSK01100 STOP CALL PSHARC(ID) CSK01110 ELSE CSK01120 KOS(IARC) = TOKVAL(3) CSK01130 KSAVE(IARC) = KOS(NARC) CSK01140 IUB(IARC) = TOKVAL(4) CSK01150 LB(IARC) = TOKVAL(5) CSK01160 FLOZOK = .FALSE. CSK01170 ENDIF CSK01180 ENDIF CSK01190 ENDIF CSK01200 ELSE CSK01210 LINES = LINES + 1 CSK01220 ENDIF CSK01230 GOTO 5 CSK01240 ENDIF CSK01250 RETURN CSK01260 1000 FORMAT(' Enter one arc per line: from to (cost (upper (lower)) CSK01270 1) or END to exit') CSK01280 1050 FORMAT(A80) CSK01290 1100 FORMAT(11X,'>> Maximum of',I8,' arcs exceeded. Exit ADD<<') CSK01300 1200 FORMAT(11X,'>> Maximum of',I5,' nodes exceeded. Exit ADD<<') CSK01310 2000 FORMAT(' >>> Token error') CSK01320 9000 FORMAT(' Please specify MODEL before adding arcs') CSK01330 END CSK01340 SUBROUTINE CHECKR CSK01350 CHARACTER*4 OPTION CSK01360 INCLUDE "command" CSK01370 IF (NTOKEN.EQ.1) THEN CSK01380 CHECK = .NOT.CHECK CSK01390 ELSE CSK01400 OPTION = TOK(2)(1:4) CSK01410 IF (OPTION .EQ. 'ON') THEN CSK01420 CHECK = .TRUE. CSK01430 ELSE IF (OPTION .EQ. 'OFF') THEN CSK01440 CHECK = .FALSE. CSK01450 ELSE CSK01460 WRITE (LUOUT,1000) OPTION CSK01470 ENDIF CSK01480 ENDIF CSK01490 IF (CHECK) WRITE (LUOUT,1100) CSK01500 IF (.NOT.CHECK) WRITE(LUOUT,1200) CSK01510 RETURN CSK01520 1000 FORMAT(' >Unknown option: ',A6) CSK01530 1100 FORMAT(' Debug is on') CSK01540 1200 FORMAT(' Debug is off') CSK01550 END CSK01560 SUBROUTINE CLS(LU) CSK01570 INCLUDE "command" CSK01580 C IF (LU.EQ.6) THEN CSK01590 C CALL CLRSCR CSK01600 C ELSE CSK01610 WRITE (LU,100) CSK01620 C ENDIF CSK01630 RETURN CSK01640 100 FORMAT( ) CSK01650 END CSK01660 SUBROUTINE CMDDEL CSK01670 C********************************************************************** CSK01680 C PROCESS DELETE COMMAND. CURRENTLY FOR DELETING ARCS ONLY. CSK01690 C FORM OF COMMAND: DELEte ARCs n1 (n2) CSK01700 C DELETES ARCS WITH ARC NUMBERS n1 THRU n2. [n2 = n1 IF MISSING] CSK01710 C********************************************************************** CSK01720 CHARACTER*3 ARCNOD CSK01730 LOGICAL ERR CSK01740 INCLUDE "command" CSK01750 INCLUDE "csk" CSK01760 C CSK01770 C CHECK FOR ERRORS CSK01780 C CSK01790 ARCNOD = TOK(2)(1:3) CSK01800 IF (NTOKEN.LE.2 .OR. ARCNOD.NE.'ARC') THEN CSK01810 ERR = .TRUE. CSK01820 ELSE IF (.NOT.TOKNUM(3) .OR. CSK01830 1 (NTOKEN.GE.4 .AND. .NOT. TOKNUM(4)) ) THEN CSK01840 ERR = .TRUE. CSK01850 ELSE CSK01860 ERR = .FALSE. CSK01870 ENDIF CSK01880 IF (ERR) THEN CSK01890 WRITE(LUOUT,1000) CSK01900 C CALL HLPMSG('DELE') CSK01910 RETURN CSK01920 ENDIF CSK01930 C CSK01940 C NORMAL PROCESSING CSK01950 C CSK01960 N1 = TOKVAL(3) CSK01970 IF (NTOKEN.GE.4) THEN CSK01980 N2 = TOKVAL(4) CSK01990 ELSE CSK02000 N2 = N1 CSK02010 ENDIF CSK02020 IF (N1.LT.1 .OR. N1.GT.NARC .OR. N1.GT.N2 .OR. N2.LT.1 .OR. CSK02030 1 N2.GT.NARC) THEN CSK02040 WRITE (LUOUT,1100) CSK02050 RETURN CSK02060 ENDIF CSK02070 C CSK02080 WRITE(LUOUT,1200) CSK02090 FLOZOK = .FALSE. CSK02100 CHGMOD = .FALSE. CSK02110 DO 10 K=N1,N2 CSK02120 ID = ARCID(N1) CSK02130 I = IFROM(ID) CSK02140 J = JTO(ID) CSK02150 WRITE (LUOUT,1300) K,NODNAM(I),NODNAM(J),KOS(ID),IUB(ID), CSK02160 1 LB(ID) CSK02170 CALL PSHARC(N1) CSK02180 10 CONTINUE CSK02190 WRITE(LUOUT,1400) CSK02200 RETURN CSK02210 C CSK02220 C FORMATS CSK02230 C CSK02240 1000 FORMAT(' The correct forms of the DELETE command are as follows:' CSK02250 */' DELETE ARC n1 or DELETE ARC n1 n2') CSK02260 1100 FORMAT(' There is some problem in the arc numbers given.') CSK02270 1200 FORMAT(' The following arc(s) have been deleted:') CSK02280 1300 FORMAT(1X,I5,2(2X,A8),' COST =',I7,' UB =',I8,' LB =',I8) CSK02290 1400 FORMAT(/' NOTE: new arc numbers have been assigned.') CSK02300 END CSK02310 SUBROUTINE CMDDSP CSK02320 C********************************************************************** CSK02330 C PROCESS DISPLAY COMMAND AND ASSOCIATED OPTIONS CSK02340 C********************************************************************** CSK02350 CHARACTER OPTION*4 CSK02360 INCLUDE "command" CSK02370 IF (NTOKEN.EQ.1 .OR. (NTOKEN.GE.2 .AND. TOKNUM(2)) ) THEN CSK02380 CALL CMDLST(LUOUT) CSK02390 IF (RECON) CALL CMDLST(LUREC) CSK02400 IF (RDSKON) CALL CMDLST(LUDISK) CSK02410 RETURN CSK02420 ENDIF CSK02430 OPTION = TOK(2)(1:4) CSK02440 IF (OPTION.EQ.'SOLU') THEN CSK02450 CALL DSPSOL(0,LUOUT) CSK02460 IF (RECON) CALL DSPSOL(0,LUREC) CSK02470 IF (RDSKON) CALL DSPSOL(0,LUDISK) CSK02480 RETURN CSK02490 ELSE IF (OPTION .EQ. 'POSI') THEN CSK02500 CALL DSPSOL(1,LUOUT) CSK02510 IF (RECON) CALL DSPSOL(1,LUREC) CSK02520 IF (RDSKON) CALL DSPSOL(1,LUDISK) CSK02530 RETURN CSK02540 ELSE IF (OPTION .EQ. 'STAT') THEN CSK02550 CALL DSPSTA(LUOUT) CSK02560 IF (RECON) CALL DSPSTA(LUREC) CSK02570 IF (RDSKON) CALL DSPSTA(LUDISK) CSK02580 RETURN CSK02590 ELSE IF (OPTION .EQ. 'NODE') THEN CSK02650 CALL DSPNOD(LUOUT) CSK02660 IF (RECON) CALL DSPNOD(LUOUT) CSK02670 IF (RDSKON) CALL DSPNOD(LUDISK) CSK02680 RETURN CSK02690 ELSE CSK02700 WRITE(LUOUT,100) TOK(2) CSK02710 RETURN CSK02720 ENDIF CSK02730 * RETURN CSK02740 100 FORMAT(11X,'>Unknown DISPLAY option: ',A8,'<') CSK02750 END CSK02760 LOGICAL FUNCTION CMDEXE(I) CSK02770 C*** EXECUTE COMMAND I, RETURN=.F.IF TIME TO QUIT OPTNET CSK02780 CHARACTER MSGLIN*15, CNAME*4 CSK02790 INCLUDE "command" CSK02800 MSGLIN = ':'//CMDNAM(I)//':' CSK02810 C WRITE (LUOUT,1000) MSGLIN CSK02820 CMDEXE = .FALSE. CSK02830 CNAME = CMDNAM(I)(1:4) CSK02840 IF (CNAME.EQ.'MODE') THEN CSK02850 CALL MODEL CSK02860 ELSE IF (CNAME.EQ.'ADD') THEN CSK02870 CALL ADD CSK02880 ELSE IF (CNAME.EQ.'SOLV') THEN CSK02950 CALL SOLVE CSK02960 ELSE IF (CNAME.EQ.'LIST') THEN CSK02970 CALL CMDLST(LUOUT) CSK02980 ELSE IF (CNAME.EQ.'DISP') THEN CSK03010 CALL CMDDSP CSK03020 ELSE IF (CNAME.EQ.'STAT') THEN CSK03050 CALL DSPSTA(LUOUT) CSK03060 ELSE IF (CNAME.EQ.'QUIT') THEN CSK03150 CALL QUIT CSK03160 CMDEXE = .TRUE. CSK03170 ELSE IF (CNAME.EQ.'HELP') THEN CSK03180 CALL HELP CSK03190 ELSE IF (CNAME.EQ.'SOLU') THEN CSK03200 CALL DSPSOL(0,LUOUT) CSK03210 ELSE IF (CNAME.EQ.'NODE') THEN CSK03240 CALL DSPNOD(LUOUT) CSK03250 ELSE IF (CNAME.EQ.'REPL') THEN CSK03320 CALL CMDREP CSK03330 ELSE IF (CNAME.EQ.'DEBU') THEN CSK03340 CALL CHECKR CSK03350 ENDIF CSK03380 RETURN CSK03390 1000 FORMAT(11X,A15) CSK03400 END CSK03410 INTEGER FUNCTION CMDGET() CSK03420 C*** GET AND PARSE NEXT COMMAND LINE *** CSK03430 LOGICAL GETTOK CSK03440 INCLUDE "command" CSK03450 LUCOM=5 CSK03460 CMDGET = 0 CSK03470 10 CONTINUE C10 WRITE (LUOUT,99) CSK03480 99 FORMAT(11X,':COMMAND?:') CSK03490 15 IF (.NOT.GETTOK())GOTO 10 CSK03500 TOKVAL(1) = LOOKUP(TOK(1),4,CMDNAM,NUMCMD) CSK03510 IF (TOKVAL(1) .EQ. 0) CMDGET = -1 CSK03520 RETURN CSK03530 999 IF (LUCOM.EQ.5) THEN CSK03540 CLOSE (5) CSK03550 OPEN (5) CSK03560 ENDIF CSK03570 GOTO 15 CSK03580 100 FORMAT(A80) CSK03590 END CSK03600 SUBROUTINE CMDLST(LU) CSK03610 INCLUDE "csk" CSK03620 INCLUDE "command" CSK03630 N1 = 1 CSK03640 N2 = NARC CSK03650 IF (NTOKEN.GE.2) THEN CSK03660 IF (TOKNUM(2)) THEN CSK03670 N1 = TOKVAL(2) CSK03680 IF (NTOKEN.GE.3 .AND. TOKNUM(3)) N2 = TOKVAL(3) CSK03690 ELSE CSK03700 IF (LU.EQ.LUOUT) WRITE (LU,1000) TOK(2) CSK03710 ENDIF CSK03720 ENDIF CSK03730 * CSK03740 CALL CLS(LU) CSK03750 LINES = 0 CSK03760 IF (LU.EQ.LUOUT) THEN CSK03770 LINPHD = LINPSC CSK03780 ELSE CSK03790 LINPHD = LINPPG CSK03800 ENDIF CSK03810 DO 10 I10=N1,N2 CSK03820 I = ARCID(I10) CSK03830 IF (MOD(LINES,LINPHD).EQ.0) THEN CSK03840 IF (LU.EQ.LUOUT) THEN CSK03850 WRITE (LU,1100) MODNAM,TITLE CSK03860 ELSE CSK03870 WRITE (LU,1150)MODNAM,TITLE CSK03880 ENDIF CSK03890 LINES = LINES + 3 CSK03900 ENDIF CSK03910 II = IFROM(I) CSK03920 JJ = JTO(I) CSK03930 WRITE(LU,1200)I10,NODNAM(II),NODNAM(JJ),KSAVE(I),IUB(I),LB(I) CSK03940 IF (CHECK) WRITE(LU,1300)I,II,JJ CSK03950 10 LINES = LINES + 1 CSK03960 WRITE (LU,1200) CSK03970 RETURN CSK03980 1000 FORMAT(' >>> Unknown option: ',A8) CSK03990 1100 FORMAT(' Model ',A8,' Title: ',A53/ CSK04000 1 ' Arcno From To Cost Upper Lower',/ CSK04010 2 ' ----- ---- -- ---- ----- -----') CSK04020 1150 FORMAT(' MODEL ',A8,' TITLE: ',A53/ CSK04030 1 ' ARCNO FROM TO COST UPPER LOWER',/ CSK04040 2 ' ----- ---- -- ---- ----- -----') CSK04050 1200 FORMAT(I6,2X,A8,2X,A8,I8,2I10) CSK04060 1300 FORMAT(' >',I4,I8,I10) CSK04070 END CSK04080 CSK04090 SUBROUTINE CMDREP CSK04100 LOGICAL TOKARC, MORE, GETTOK CSK04110 INTEGER ARCNO CSK04120 INCLUDE "csk" CSK04130 INCLUDE "command" CSK04140 IF (NTOKEN.GE.2 .AND. TOKNUM(2)) THEN CSK04150 ARCNO = TOKVAL(2) CSK04160 CALL CMDRE2(ARCNO,MORE) CSK04170 RETURN CSK04180 ENDIF CSK04190 * (NO ARCNO SHOWN, GO INTO REPLACE LOOP) CSK04200 MORE = .TRUE. CSK04210 10 IF (MORE) THEN CSK04220 WRITE (LUOUT,1000) CSK04230 MORE = GETTOK() CSK04240 IF (.NOT.MORE) GOTO 10 CSK04250 IF (.NOT.TOKNUM(1)) THEN CSK04260 IF (TOK(1) .EQ. 'END') MORE = .FALSE. CSK04270 GOTO 10 CSK04280 ENDIF CSK04290 ARCNO = TOKVAL(1) CSK04300 CALL CMDRE2(ARCNO,MORE) CSK04310 GOTO 10 CSK04320 ENDIF CSK04330 RETURN CSK04340 1000 FORMAT(11X,'Ready for index of arc to replace or END') CSK04350 END CSK04360 SUBROUTINE CMDRE2(ARCNO,MORE) CSK04370 * (GET DATA TO REPLACE ARC 'ARCNO') CSK04380 LOGICAL MORE, GETTOK, TOKARC CSK04390 INTEGER ARCNO CSK04400 INCLUDE "csk" CSK04410 INCLUDE "command" CSK04420 IF (ARCNO.LT.1 .OR. ARCNO.GT.NARC) THEN CSK04430 WRITE (LUOUT,1010) NARC CSK04440 WRITE(LUOUT,1030) CSK04450 MORE = .TRUE. CSK04460 RETURN CSK04470 ENDIF CSK04480 IARC = ARCID(ARCNO) CSK04490 II = IFROM(IARC) CSK04500 JJ = JTO(IARC) CSK04510 WRITE (LUOUT,1020) NODNAM(II), NODNAM(JJ), KSAVE(IARC), CSK04520 + IUB(IARC), LB(IARC) CSK04530 MORE = GETTOK() CSK04540 IF (.NOT.MORE) RETURN CSK04550 IF (TOKARC()) THEN CSK04560 IF (NTOKEN .EQ. 1) THEN CSK04570 MORE = .FALSE. CSK04580 WRITE(LUOUT,1030) CSK04590 ELSE CSK04600 CALL SETARC(IARC,IERR) CSK04610 IF (IERR.EQ.0) MODS = MODS+1 CSK04620 ENDIF CSK04630 ELSE CSK04640 WRITE (LUOUT,1030) CSK04650 ENDIF CSK04660 RETURN CSK04670 * CSK04680 1010 FORMAT(11X,'>Arc index should be between 1 and ',I5,'<') CSK04690 1020 FORMAT( CSK04700 1 1X,'Replacing arc: ',A8,2X,A8,' Cost=',I6,' Upper=', CSK04710 2 I9,' Lower=',I6/ CSK04720 3 11X,'Ready for replacement: from to (cost (upper (lower)))', CSK04730 4 ' or END') CSK04740 1030 FORMAT(' >Arc not replaced') CSK04750 END CSK04760 SUBROUTINE DISPLA CSK04770 CHARACTER DATTIM*23 CSK04780 INCLUDE "csk" CSK04790 INCLUDE "command" CSK04800 ENTRY DSPSOL(MINFLO,LU1) CSK04810 C********************************************************************** CSK04820 C REPORT ON CURRENT SOLUTION, SHOW ARCS WHOSE FLOW >= MINFLO CSK04830 C********************************************************************** CSK04840 LU = LU1 CSK04850 CALL CLS(LU) CSK04860 TCOST = 0.0 CSK04870 LINES = 0 CSK04880 DO 10 I10=1,NARC CSK04890 I = ARCID(I10) CSK04900 IF (MOD(LINES,LINPSC) .EQ. 0) THEN CSK04910 IF (LU.EQ.6) THEN CSK04920 WRITE (LU,1000) MODNAM,TITLE CSK04930 ELSE CSK04940 WRITE (LU,1001) MODNAM,TITLE CSK04950 ENDIF CSK04960 LINES = LINES + 3 CSK04970 ENDIF CSK04980 IF (KFLOW(I) .GE. MINFLO) THEN CSK04990 II = IFROM(I) CSK05000 JJ = JTO(I) CSK05010 WRITE (LU,1100) I10,NODNAM(II),NODNAM(JJ), KSAVE(I), CSK05020 * -KOS(I), KFLOW(I), IUB(I), LB(I) CSK05030 IF (CHECK) WRITE (LU,1125) I10,II,JJ CSK05040 LINES = LINES + 1 CSK05050 ENDIF CSK05060 10 TCOST = TCOST + KSAVE(I)*KFLOW(I) CSK05070 IF (LU.EQ.6) THEN CSK05080 WRITE (LU,1150) STAT(INFEAS+2),TCOST CSK05090 ELSE CSK05100 WRITE (LU,1151) STAT(INFEAS+2),TCOST CSK05110 ENDIF CSK05120 RETURN CSK05130 ENTRY DSPSTA(LU2) CSK05140 C********************************************************************** CSK05150 C REPORT CURRENT STATUS CSK05160 C********************************************************************** CSK05170 LU = LU2 CSK05180 C CALL DATETM(DATTIM,23,ECPU,ETIME,ETCPU) CSK05190 CALL CLS(LU) CSK05200 IF (LU.EQ.6) THEN CSK05210 WRITE (LU,1200) DATTIM,MODNAM,TITLE,OBJ,NODES,MAXN,NARC,MAXA, CSK05220 1 STAT(INFEAS+2), IZZ, MODS, CHGMOD, SOLCPU, RECON, RDSKOP CSK05230 ELSE CSK05240 WRITE (LU,1201) DATTIM,MODNAM,TITLE,OBJ,NODES,MAXN,NARC,MAXA, CSK05250 1 STAT(INFEAS+2), IZZ, MODS, CHGMOD, SOLCPU, RECON, RDSKOP CSK05260 ENDIF CSK05270 RETURN CSK05280 ENTRY DSPNOD(LU4) CSK05380 C********************************************************************** CSK05390 C REPORT ON NODES CSK05400 C********************************************************************** CSK05410 LU = LU4 CSK05420 CALL CLS(LU) CSK05430 IF (LU.EQ.6) THEN CSK05440 WRITE (LU,1300) CSK05450 ELSE CSK05460 WRITE (LU,1301) CSK05470 ENDIF CSK05480 DO 20 K=1,NODES CSK05490 20 WRITE (LU,1400) K,NODNAM(K),MIDL(K) CSK05500 WRITE (LU,1400) CSK05510 RETURN CSK05520 1000 FORMAT(' Model ',A8,' Title: ',A53/ CSK05530 1' Arcno From To Cost Modcst Flow Upper', CSK05540 2' Lower'/ CSK05550 3' ----- ---- -- ---- ------ ---- -----', CSK05560 4' -----') CSK05570 1001 FORMAT(' MODEL ',A8,' TITLE: ',A53/ CSK05580 1' ARCNO FROM TO COST MODCST FLOW UPPER', CSK05590 2' LOWER'/ CSK05600 3' ----- ---- -- ---- ------ ---- -----', CSK05610 4' -----') CSK05620 1100 FORMAT(1X,I5,2(2X,A8),5I8) CSK05630 1125 FORMAT(' >',I4,2I10,'<') CSK05640 1150 FORMAT(' Model status ',A10,6X,'Total solution cost =',F15.0) CSK05650 1151 FORMAT(' MODEL STATUS ',A10,6X,'TOTAL SOLUTION COST =',F15.0) CSK05660 1200 FORMAT( CSK05670 1 1X,15('-'),1X,A23,1X,19('-')/ CSK05680 1 ' MODEL ',A8,2X,A60/ CSK05690 2 7X,A8, ' Objective function'/ CSK05700 3 I15, ' Nodes (max =',I4,')'/ CSK05710 4 I15, ' Arcs (max =',I5,')'/ CSK05720 5 5X,A10,' Problem status'/ CSK05730 6 I15, ' Most recent objective function value (Z*)'/ CSK05740 7 I15, ' Modifications'/ CSK05750 8 14X,L1,' Modified since last SAVE?'/ CSK05760 9 F15.3, ' CPU seconds on most recent SOLVE'/ CSK05770 A 14X,L1,' Recording of reports?'/ CSK05780 B 14X,L1,' Record-to-disk?'/ CSK05790 * 1X,59('-')) CSK05800 1201 FORMAT( CSK05810 1 1X,15('-'),1X,A23,1X,19('-')/ CSK05820 1 ' MODEL ',A8,2X,A60/ CSK05830 2 7X,A8, ' OBJECTIVE FUNCTION'/ CSK05840 3 I15, ' NODES (MAX =',I4,')'/ CSK05850 4 I15, ' ARCS (MAX =',I5,')'/ CSK05860 5 5X,A10,' PROBLEM STATUS'/ CSK05870 6 I15, ' MOST RECENT OBJECTIVE FUNCTION VALUE (Z*)'/ CSK05880 7 I15, ' MODIFICATIONS'/ CSK05890 8 14X,L1,' MODIFIED SINCE LAST SAVE?'/ CSK05900 9 F15.3, ' CPU SECONDS ON MOST RECENT SOLVE'/ CSK05910 A 14X,L1,' RECORDING OF REPORTS?'/ CSK05920 B 14X,L1,' RECORD-TO-DISK?'/ CSK05930 * 1X,59('-')) CSK05940 1300 FORMAT(/' *** NODE SUMMARY REPORT ***'/ CSK05950 1 ' Node # Node Name Dual'/ CSK05960 2 ' ------ --------- ----') CSK05970 1301 FORMAT(/' *** NODE SUMMARY REPORT ***'/ CSK05980 1 ' NODE # NODE NAME DUAL'/ CSK05990 2 ' ------ --------- ----') CSK06000 1400 FORMAT(I7,3X,A8,I11) CSK06010 1500 FORMAT(' A list of OPTNET model files:') CSK06020 END CSK06030 SUBROUTINE DUALS CSK06040 C **************************************************************** CSK06050 C SUBROUTINE TO COMPUTE DUALS FROM MARGINAL AND ACTUAL COSTS. CSK06060 C CSK06070 C KDUAL = 0, FOR NO DUAL COMPUTATION CSK06080 C I, NUMBER OF NODE WITH POTENTIAL SET TO ZERO CSK06090 C KSAVE - (INPUT) VECTOR OF ORIGINAL COSTS, ORDERED PER ARC DATA CSK06100 C MIDL = (OUTPUT) VECTOR OF NODE POTENTIALS (DUALS) CSK06110 C CSK06120 C **************************************************************** CSK06130 INCLUDE "csk" CSK06140 IF(KDUAL.LE.0) RETURN CSK06150 MIDL(KDUAL)=0 CSK06160 LABL(KDUAL)=-1 CSK06170 NLAB=1 CSK06180 IWV(NLAB)=KDUAL CSK06190 NO=0 CSK06200 20 NO=NO+1 CSK06210 IF(NO.GT.NLAB) RETURN CSK06220 IA=IWV(NO) CSK06230 IW=MIDL(IA) CSK06240 IB=NODE(IA) CSK06250 IE=NODE(IA+1)-1 CSK06260 IF(IB.GT.IE) GO TO 20 CSK06270 DO 40 JJ=IB,IE CSK06280 J=IFROM(JJ) CSK06290 NUNODE=JTO(J) CSK06300 IF(LABL(NUNODE).NE.0) GO TO 40 CSK06310 LABL(NUNODE)=IA CSK06320 NLAB=NLAB+1 CSK06330 IWV(NLAB)=NUNODE CSK06340 IF(J.LE.NARC) GO TO 25 CSK06350 J=J-NARC CSK06360 MIDL(NUNODE)=-KOS(J)+IW+KSAVE(J) CSK06370 GO TO 30 CSK06380 25 MIDL(NUNODE)=-KSAVE(J)+IW+KOS(J) CSK06390 30 IF(NLAB.GE.NODES) RETURN CSK06400 40 CONTINUE CSK06410 GO TO 20 CSK06420 END CSK06430 LOGICAL FUNCTION GETLIN(BUF,LENBUF) CSK06440 *********************************************************************** CSK06450 * TAKES A LINE OF CHARACTERS FROM STANDARD INPUT (LUCOM) CSK06460 * AND RETURNS .TRUE. UNLESS THERE WAS NO USER RESPONSE CSK06470 *********************************************************************** CSK06480 CHARACTER BUF(LENBUF) CSK06490 LOGICAL ISEMPTY INCLUDE "command" CSK06500 GETLIN = .TRUE. CSK06510 5 READ (LUCOM,1050, END=99, ERR=99) BUF CSK06520 if (ISEMPTY(BUF,LENBUF)) goto 5 RETURN CSK06530 99 IF (LUCOM.EQ.5) THEN CSK06540 CLOSE (5) CSK06550 OPEN (5) CSK06560 ENDIF CSK06570 GETLIN = .FALSE. CSK06580 RETURN CSK06590 1050 FORMAT(80A1) CSK06600 END CSK06610 LOGICAL FUNCTION ISEMPTY(BUF,LENBUF) CHARACTER BUF(LENBUF) CSK06490 ISEMPTY = .FALSE. do 10 i=1,LENBUF if (BUF(i).ne.' ') return 10 continue ISEMPTY = .TRUE. RETURN END LOGICAL FUNCTION GETTOK() CSK06620 ********************************************************************** CSK06630 * FUNCTION GETS LINE FROM INPUT DEVICE, TOKENIZES IT, AND CSK06640 * SETS TOKEN ARRAYS, INCLUDING TOKNUM(), TOKVAL(). CSK06650 * RETURNS: TRUE = NORMAL RETURN, FALSE = ERROR OR NO USER RESPONSECSK06660 ************************************************************************CSK06670 LOGICAL GETLIN CSK06680 INCLUDE "csk" CSK06690 INCLUDE "command" CSK06700 5 GETTOK = GETLIN(INCHAR,80) CSK06710 IF (GETTOK) THEN CSK06720 IF (IPARSE().NE.0) THEN CSK06730 WRITE (LUOUT,2000) CSK06740 STOP CSK06750 ENDIF CSK06760 ENDIF CSK06770 RETURN CSK06780 2000 FORMAT(11X,'>Too many words on line - please reenter<') CSK06790 END CSK06800 SUBROUTINE GREET CSK06810 INCLUDE "csk" CSK06820 INCLUDE "command" CSK06830 CALL CLS(LUOUT) CSK06840 WRITE (LUOUT,1000) VERSON, MAXN, MAXA CSK06850 RETURN CSK06870 1000 FORMAT(30X,' *** OPTNET ',F3.1,' ***',// CSK06880 1' Written for the solution of', CSK06890 2' circularized network flow problems by R. Barr'/ CSK06900 3' Maximum problem size:',I5,' nodes and',I5,' arcs'/) CSK06910 END CSK06920 SUBROUTINE HELP CSK06930 INCLUDE "command" CSK06940 IF (NTOKEN.LT.2 .OR. TOKNUM(2)) THEN CSK06950 CALL HLPMSG('XXXX') CSK06960 ELSE CSK06970 CALL HLPMSG(TOK(2)(1:4)) CSK06980 ENDIF CSK06990 RETURN CSK07000 END CSK07010 SUBROUTINE HLPMSG(CNAME) CSK07020 CHARACTER*4 CNAME CSK07030 INCLUDE "command" CSK07040 IF (CNAME.EQ.'MODE') THEN CSK07050 WRITE(LUOUT,3010) CSK07060 ELSE IF (CNAME.EQ.'ADD') THEN CSK07070 WRITE(LUOUT,3020) CSK07080 WRITE(LUOUT,3030) CSK07090 ELSE IF (CNAME.EQ.'TITL') THEN CSK07100 WRITE(LUOUT,3040) CSK07110 ELSE IF (CNAME.EQ.'MINI') THEN CSK07120 WRITE(LUOUT,3050) CSK07130 ELSE IF (CNAME.EQ.'SOLV') THEN CSK07140 WRITE(LUOUT,3060) CSK07150 ELSE IF (CNAME.EQ.'LIST') THEN CSK07160 WRITE(LUOUT,3070) CSK07170 ELSE IF (CNAME.EQ.'DISP') THEN CSK07180 WRITE(LUOUT,3080) CSK07190 ELSE IF (CNAME.EQ.'STAT') THEN CSK07200 WRITE(LUOUT,3090) CSK07210 ELSE IF (CNAME.EQ.'RECO') THEN CSK07220 WRITE(LUOUT,3100) CSK07230 ELSE IF (CNAME.EQ.'SAVE') THEN CSK07240 WRITE(LUOUT,3110) CSK07250 ELSE IF (CNAME.EQ.'QUIT') THEN CSK07280 WRITE(LUOUT,3130) CSK07290 ELSE IF (CNAME.EQ.'HELP') THEN CSK07300 WRITE(LUOUT,3140) CSK07310 ELSE IF (CNAME.EQ.'SOLU') THEN CSK07320 WRITE(LUOUT,3150) CSK07330 ELSE IF (CNAME.EQ.'NODE') THEN CSK07340 WRITE(LUOUT,3160) CSK07350 ELSE IF (CNAME.EQ.'POSI') THEN CSK07360 WRITE(LUOUT,3170) CSK07370 ELSE IF (CNAME.EQ.'REPL') THEN CSK07380 WRITE(LUOUT,3180) CSK07390 ELSE IF (CNAME.EQ.'DELE') THEN CSK07400 WRITE(LUOUT,3190) CSK07410 ELSE IF (CNAME.EQ.'RENA') THEN CSK07420 WRITE(LUOUT,3200) CSK07430 ELSE CSK07440 WRITE (LUOUT,1000) (CMDNAM(I),I=1,NUMCMD) CSK07450 WRITE (LUOUT,1010) CSK07460 ENDIF CSK07470 RETURN CSK07480 1000 FORMAT(' The following commands are available:'/ CSK07490 1 1X,79('-')/ CSK07500 2 (8(2X,A8))) CSK07510 1010 FORMAT(1X,79('-')/ CSK07520 1 ' For help on an individual command, enter: HELP commandname') CSK07530 3010 FORMAT( CSK07540 *' MODEL Command has the following form: MODEl modname',/ CSK07550 *' where is a 1- to 8-alphanumeric character name used'/ CSK07560 *' to identify a specific network model. The user"s disk is',/ CSK07570 *' searched for the file: modname OPTNET A.',/ CSK07580 *' If found, the saved network model is read, and make the ',/ CSK07590 *' current model. If the file is not found, a new model is begun'/CSK07600 *' and is used when saving the new model to disk.') CSK07610 3020 FORMAT( CSK07620 *' ADD Command has the form: ADD',/ CSK07630 *' and is used to allow adding arcs to the network model.',/ CSK07640 *' Arcs are entered one per line, in the following form:',/ CSK07650 *' fromnode tonode (cost (upper (lower)))',/ CSK07660 *' where is a 1-8 character name of the from-node,',/ CSK07670 *' is the name of the to-node for the arc,',/ CSK07680 *' is the integer variable cost per unit of flow,',/ CSK07690 *' is the maximum flow permitted on the arc, and',/ CSK07700 *' is the minimum flow required on the arc.') CSK07710 3030 FORMAT( CSK07720 *' If is omitted, 0 is assumed.',/ CSK07730 *' If are omitted, 999999 and 0 are assumed.',/ CSK07740 *' If are omitted, 0, 999999 and 0 are used.'/CSK07750 *' To leave the ADD mode, enter: END',/ CSK07760 *' When ADD is used multiple times for a given model, new arcs'/ CSK07770 *' are always placed at the end of the arc list.') CSK07780 3040 FORMAT( CSK07790 *' TITLE Command has the form: TITLe',/ CSK07800 *' The user is then prompted for a one-line title to be used on'/ CSK07810 *' OPTNET reports.') CSK07820 3050 FORMAT( CSK07830 *' MINIMIZE Command has the form: MINImize',/ CSK07840 *' and indicates that the problem is to minimize total cost.',/ CSK07850 *' This is what OPTNET assumes, and the only objective available'/ CSK07860 *' at this time.') CSK07870 3060 FORMAT( CSK07880 *' SOLVE Command has the form: SOLVe',/ CSK07890 *' and directs OPTNET to try and optimize the current model.',/ CSK07900 *' Upon completion, OPTNET gives the problem status, objective',/ CSK07910 *' function value, and CPU time used. To see the network ',/ CSK07920 *' solution, use the DISPLAY commands.') CSK07930 3070 FORMAT( CSK07940 *' LIST Command has the form: LIST (n1 (n2))',/ CSK07950 *' where and are arc identification numbers.',/ CSK07960 *' If LIST is given with no arc numbers, all arcs in the current'/ CSK07970 *' model are listed. If form is used, all arcs from',/ CSK07980 *' to the end of the arc list are shown. If ',/ CSK07990 *' form is used, arcs numbered through are displayed.') CSK08000 3080 FORMAT( CSK08010 *' DISPLAY Command has the forms:',/ CSK08020 *' DISPlay n1 n2 - lists arc numbered thru ',/ CSK08030 *' Identical to LIST command.',/ CSK08040 *' (DISPlay) SOLUtion - Displays current solution.',/ CSK08050 *' (DISPlay) POSItive - Show positive flow arcs only.',/ CSK08060 *' (DISPlay) STATus - Show current model status.',/ CSK08070 *' (DISPlay) FILEs - List files with SAVEd models',/ CSK08080 *' (DISPlay) NODEs - Node duals summary report.',/ CSK08090 *' Since, in most cases, the keyword DISPLAY is optional, see',/ CSK08100 *' the HELP message for the type of report desired, such as STAT.')CSK08110 3090 FORMAT( CSK08120 *' STATUS Command has the form: STATus or DISPlay STATus'/ CSK08130 *' Gives a status report on the current model. Hopefuly, the ',/ CSK08140 *' information is self-explanatory.') CSK08150 3100 FORMAT( CSK08160 *' RECORD Command has the form: RECOrd [ON | OFF | PRINT ]'/ CSK08170 *' This command controls the recording of LIST and DISPLAY',/ CSK08180 *' reports for hard copy (printed) output. When ',/ CSK08190 *' is issued, a copy of all subsequent reports is saved for '/ CSK08200 *' printing. suspends the recording of reports.',/ CSK08210 *' prints all recorded reports and starts a new',/ CSK08220 *' recording.') CSK08230 3110 FORMAT( CSK08240 *' SAVE Command has the form: SAVE',/ CSK08250 *' This causes the current model to be saved to disk in a file',/ CSK08260 *' named , where is the name of the',/ CSK08270 *' current model. This allows the user to retrieve the model at',/CSK08280 *' a later date by issuing the command: .') CSK08290 3120 FORMAT( CSK08300 *' FILES Command has the form: FILEs or DISPlay FILEs',/ CSK08310 *' This command generates a list of user files whose name is of',/ CSK08320 *' the form: modelname OPTNET A'/ CSK08330 *' This should be the list of saved network models which can be'/ CSK08340 *' retrieved with the MODEL command.') CSK08350 3130 FORMAT( CSK08360 *' QUIT Command has the form: QUIT'/ CSK08370 *' This is used to leave the OPTNET program. The user is given'/ CSK08380 *' the option of saving his/her current model and printing any'/ CSK08390 *' recorded reports.') CSK08400 3140 FORMAT( CSK08410 *' HELP Command has the form: HELP (commandname)'/ CSK08420 *' , by itself, simply lists out the available commands.'/ CSK08430 *' For detailed information on any given command, the user should'/CSK08440 *' use the form: .') CSK08450 3150 FORMAT( CSK08460 *' SOLUTION Command has the forms: SOLUtion or DISPlay SOLUtion'/CSK08470 *' Displays the current solution for the network. Specifically,'/ CSK08480 *' for each arc in the model, its arc number, from node, to node,'/CSK08490 *' cost, marginal cost, upper/lower bounds, and flow is shown.') CSK08500 3160 FORMAT( CSK08510 *' NODE Command has the forms: NODEs or DISPlay NODEs'/ CSK08520 *' Gives a summary report on each of the nodes in the current'/ CSK08530 *' model, specifically the node name and its dual value.') CSK08540 3170 FORMAT( CSK08550 *' POSITIVE Command has the forms: POSItive or DISPlay POSItive'/CSK08560 *' Is identical to the command, except only'/ CSK08570 *' those arcs with positive flow are shown.') CSK08580 3180 FORMAT( CSK08590 *' REPLACE Command has the form: REPLace'/ CSK08600 *' Allows the user to replace arcs in the current model with'/ CSK08610 *' different arcs. All arcs are referred to by their unique arc'/ CSK08620 *' numbers, as shown by the LIST command. Several arcs may be'/ CSK08630 *' replaced one-at-a-time. Type END to stop replacement mode.') CSK08640 3190 FORMAT( CSK08650 *' DELETE Command has the form: DELEte ARCs n1 (n2)'/ CSK08660 *' where and are arc identifier numbers. This command'/ CSK08670 *' causes the arc(s) to be deleted from the current model.'/ CSK08680 *' If is omitted, only arc number is deleted. If '/ CSK08690 *' is included, arcs numbered through are deleted.'/ CSK08700 *' NOTE that new arc sequence numbers are assigned after a DELETE.'CSK08710 *) CSK08720 3200 FORMAT( CSK08730 *' RENAME Command has the form: RENAme modname'/ CSK08740 *' where is a 1- to 8-alphanumeric character name which'/CSK08750 *' is to replace the current model name. If model '/ CSK08760 *' already exists, the previous name will be retained.' CSK08770 *) CSK08780 END CSK08790 FUNCTION IPARSE() CSK08800 C*** COMMAND LINE PARSER *** CSK08810 INCLUDE "command" CSK08820 CALL TOKEN(INCHAR,MAXCHR,TOK,8*MAXTOK,NTOKEN,IERR) CSK08830 IPARSE=IERR CSK08840 C IF (IPARSE.NE.0) RETURN CSK08850 DO 10 I=1,NTOKEN CSK08860 CALL CTI(TOK(I),8,NRR,TOKVAL(I),1) CSK08870 IF (NRR.EQ.1) THEN CSK08880 TOKNUM(I) = .TRUE. CSK08890 ELSE CSK08900 TOKNUM(I) = .FALSE. CSK08910 ENDIF CSK08920 10 CONTINUE CSK08930 RETURN CSK08940 END CSK08950 FUNCTION LOOKUP(STRING,NCHAR,LIST,NLIST) CSK08960 C*** GET COMMAND INDEX NUMBER FOR THIS COMMAND NAME *** CSK08970 CHARACTER*8 STRING, LIST(NLIST) CSK08980 DO 10 LOOKUP=1, NLIST CSK08990 IF (STRING(1:NCHAR) .EQ. LIST(LOOKUP)(1:NCHAR)) RETURN CSK09000 10 CONTINUE CSK09010 LOOKUP = 0 CSK09020 RETURN CSK09030 END CSK09040 SUBROUTINE MAX CSK09050 INCLUDE "command" CSK09060 MINMAX = -1 CSK09070 OBJ = 'MAXIMIZE' CSK09080 10 WRITE (LUOUT,1000) OBJ CSK09090 RETURN CSK09100 * CSK09110 ENTRY MIN CSK09120 MINMAX = +1 CSK09130 OBJ = 'MINIMIZE' CSK09140 GOTO 10 CSK09150 1000 FORMAT(5X,A8,' objective (cost).') CSK09160 END CSK09170 SUBROUTINE MODEL CSK09180 CHARACTER NEWMOD*8, YESNO, FILEID*20, RECFM*2 CSK09190 LOGICAL NVALID, INOK, GETTOK CSK09200 INCLUDE "command" CSK09210 IF (NTOKEN.GE.2 .AND. .NOT.TOKNUM(2)) THEN CSK09220 NEWMOD = TOK(2) CSK09230 ELSE CSK09240 NEWMOD = '*ERROR*' CSK09250 ENDIF CSK09260 C WRITE(LUOUT,1250) NEWMOD CSK09420 MODNAM = NEWMOD CSK09440 CHGMOD = .FALSE. CSK09450 LU = LUMOD CSK09470 CALL NEWNET CSK09500 CALL TITL CSK09560 ISMODL = .TRUE. CSK09630 RETURN CSK09640 1000 FORMAT(' Please enter new model name (letter plus up to 7 letters CSK09650 1and digits) or IGNORE') CSK09660 1100 FORMAT(A8) CSK09670 1200 FORMAT(' Do you wish to save your updated current model?') CSK09680 1250 FORMAT(' Begin model ',A8) CSK09690 1300 FORMAT(' >>> UOPEN error',I3,' for file ',A20) CSK09700 1400 FORMAT(' Ready for entry of new model.') CSK09710 1500 FORMAT(' Retrieving previously-saved model.') CSK09720 END CSK09730 SUBROUTINE NEWNET CSK09740 INCLUDE "csk" CSK09750 INCLUDE "command" CSK09760 NODES = 0 CSK09770 NARC = 0 CSK09780 OBJ = 'MINIMIZE' CSK09790 MINMAX= +1 CSK09800 TITLE = '*** OPTNET NETWORK MODEL ***' CSK09810 INFEAS= -1 CSK09820 MODS = 0 CSK09830 SOLCPU = -.00001 CSK09840 IER = 0 CSK09850 CHGMOD= .FALSE. CSK09860 DO 10 I=1,MAXA CSK09870 10 ARCID(I) = I CSK09880 RETURN CSK09890 END CSK09900 SUBROUTINE NODENO(IA,NODINX) CSK09910 CHARACTER IA*8 CSK09920 INCLUDE "csk" CSK09930 IF(NODES.GT.0) THEN CSK09940 DO 20 NODINX=1,NODES CSK09950 IF(NODNAM(NODINX).EQ.IA) RETURN CSK09960 20 CONTINUE CSK09970 IF(NODES.EQ.MAXN) THEN CSK09980 NODINX = 0 CSK09990 RETURN CSK10000 ENDIF CSK10010 ENDIF CSK10020 C (ADD NODE TO LIST) CSK10030 NODES=NODES+1 CSK10040 NODINX=NODES CSK10050 NODNAM(NODES)=IA CSK10060 RETURN CSK10070 END CSK10080 LOGICAL FUNCTION NVALID(NAME) CSK10090 * (.T. = NAME IS INVALID AS FILENAME) CSK10100 CHARACTER NAME*8, SPACE8*8 CSK10110 INTEGER C CSK10120 IA = ICHAR('A') CSK10130 IZ = ICHAR('Z') CSK10140 I0 = ICHAR('0') CSK10150 I9 = ICHAR('9') CSK10160 SPACE8 = ' ' CSK10170 NVALID = .TRUE. CSK10180 C = ICHAR(NAME(1:1)) CSK10190 IF (C.LT.IA .OR. C.GT.IZ) RETURN CSK10200 DO 10 I=2,8 CSK10210 C = ICHAR(NAME(I:I)) CSK10220 IF((C.LT.IA .OR. C.GT.IZ).AND.(C.LT.I0 .OR. C.GT.I9)) THEN CSK10230 IF (NAME(I:8) .NE. SPACE8(I:8)) RETURN CSK10240 GOTO 20 CSK10250 ENDIF CSK10260 10 CONTINUE CSK10270 20 NVALID = .FALSE. CSK10280 RETURN CSK10290 END CSK10300 SUBROUTINE OUTPUT(INPERR) CSK10310 CHARACTER*8 CMD CSK10320 INCLUDE "csk" CSK10330 INCLUDE "command" CSK10340 INPERR = 0 CSK10350 IF (CHGMOD) THEN CSK10360 REWIND LUMOD CSK10370 WRITE (LUMOD,1000,ERR=90) TITLE,OBJ CSK10380 DO 10 J=1,NARC CSK10390 I = ARCID(J) CSK10400 II=IFROM(I) CSK10410 JJ=JTO(I) CSK10420 10 WRITE (LUMOD,1100) NODNAM(II),NODNAM(JJ), CSK10430 1 KSAVE(I), IUB(I), LB(I) CSK10440 WRITE (LUMOD,1200,ERR=90) CSK10450 WRITE (LUOUT,1300) MODNAM CSK10460 CHGMOD = .FALSE. CSK10470 ELSE CSK10480 WRITE (LUOUT,1400,ERR=90) CSK10490 ENDIF CSK10500 RETURN CSK10510 * (WRITE ERROR) CSK10520 90 INPERR = 4 CSK10530 RETURN CSK10540 * CSK10550 ENTRY BATCH(INPERR) CSK10560 INPERR = 0 CSK10570 CALL NEWNET CSK10580 REWIND LUMOD CSK10590 * (COMMAND PROCESSING LOOP) CSK10600 100 READ (LUMOD,2005, END=200, ERR=200) CMD CSK10610 IF (CMD .EQ. 'TITLE') THEN CSK10620 READ (LUMOD,2010, END=200, ERR=200) TITLE CSK10630 C WRITE (LUOUT,2015) TITLE CSK10640 GOTO 100 CSK10650 ELSE IF (CMD .EQ. 'MAXIMIZE') THEN CSK10660 OBJ = CMD CSK10670 MINMAX = -1 CSK10680 GOTO 100 CSK10690 ELSE IF (CMD .EQ. 'MINIMIZE') THEN CSK10700 OBJ = CMD CSK10710 MINMAX = +1 CSK10720 GOTO 100 CSK10730 ELSE IF (CMD .EQ. 'RETURN') THEN CSK10740 WRITE (LUOUT, 2040) NODES, NARC, OBJ CSK10750 RETURN CSK10760 ELSE IF (CMD .EQ. 'ADD') THEN CSK10770 110 CALL POPARC(ID) CSK10780 FLOZOK = .FALSE. CSK10790 IF (ID.GT.0) THEN CSK10800 READ (LUMOD,1100, END=200, ERR=200) TOK(1),TOK(2), CSK10810 1 KOS(NARC), IUB(NARC), LB(NARC) CSK10820 IF (TOK(1) .EQ. 'END') GOTO 130 CSK10830 KSAVE(NARC) = KOS(NARC) CSK10840 CALL NODENO(TOK(1),IFROM(NARC)) CSK10850 CALL NODENO(TOK(2),JTO(NARC)) CSK10860 IF (IFROM(NARC).EQ.0 .OR. JTO(NARC).EQ.0) THEN CSK10870 WRITE (LUOUT,2020) MAXN CSK10880 INPERR = 1 CSK10890 RETURN CSK10900 ENDIF CSK10910 GOTO 110 CSK10920 ENDIF CSK10930 READ (LUMOD,1100, END=200, ERR=200) TOK(1) CSK10940 IF (TOK(1) .NE. 'END') THEN CSK10950 WRITE(LUOUT,2030) MAXA CSK10960 INPERR = 2 CSK10970 RETURN CSK10980 ENDIF CSK10990 130 CALL PSHARC(ID) CSK11000 GOTO 100 CSK11010 ELSE CSK11020 WRITE (LUOUT,2050) CMD CSK11030 INPERR = 3 CSK11040 RETURN CSK11050 ENDIF CSK11060 * (READ ERROR) CSK11070 200 INPERR = 4 CSK11080 RETURN CSK11090 1000 FORMAT('TITLE'/A60/A8/'ADD') CSK11100 1100 FORMAT(2(A8,2X),3I10) CSK11110 1200 FORMAT('END'/'RETURN') CSK11120 1300 FORMAT(' Model saved on file: ',A8,' OPTNET A') CSK11130 1400 FORMAT(' No changes made since last SAVE.') CSK11140 2005 FORMAT(A8) CSK11150 2010 FORMAT(A50) CSK11160 2015 FORMAT(11X,'Title: ',A60) CSK11170 2020 FORMAT(' >>> Maximum of',I5,' nodes exceeded.') CSK11180 2030 FORMAT(' >>> Maximum of',I6,' arcs exceeded') CSK11190 2040 FORMAT(' Model ready.',I6,' nodes,',I8,' arcs, ',A8,' objective') CSK11200 2050 FORMAT(' Unknown directive on model file: ',A8) CSK11210 END CSK11220 SUBROUTINE QUIT CSK11230 CHARACTER YESNO CSK11240 INCLUDE "command" CSK11250 WRITE (LUOUT,1010) CSK11300 CALL EXIT CSK11310 1000 FORMAT(' Do you wish to save your current model?') CSK11320 C1010 FORMAT(11X,':QUIT OPTNET:') CSK11330 1010 FORMAT(/' Exit Optnet' ) CSK11330 END CSK11340 SUBROUTINE POPARC(ID) CSK11350 INCLUDE "command" CSK11360 INCLUDE"csk" CSK11370 IF (NARC.LT.MAXA) THEN CSK11380 NARC = NARC+1 CSK11390 ID = NARC CSK11400 ELSE CSK11410 ID = -1 CSK11420 ENDIF CSK11430 RETURN CSK11440 END CSK11450 SUBROUTINE PSHARC(ID) CSK11460 INCLUDE "command" CSK11470 INCLUDE "csk" CSK11480 IF (ID.LT.1 .OR. ID.GT.NARC) THEN CSK11490 WRITE(LUOUT,1000) ID CSK11500 RETURN CSK11510 ENDIF CSK11520 IF (ID.LT.NARC) THEN CSK11530 ISAVE = ARCID(ID) CSK11540 DO 10 K=ID,NARC-1 CSK11550 10 ARCID(K) = ARCID(K+1) CSK11560 ARCID(NARC) = ISAVE CSK11570 ENDIF CSK11580 NARC = NARC -1 CSK11590 RETURN CSK11600 1000 FORMAT(' Deleting nonexistent arc ',I5) CSK11610 END CSK11620 SUBROUTINE RETR CSK13740 INCLUDE "command" CSK13750 CALL BATCH(INPERR) CSK13760 * (BATCH IS ENTRY POINT TO SUBROUTINE OUTPUT) CSK13770 IF (INPERR .NE. 0) WRITE (LUOUT,100) CSK13780 RETURN CSK13790 100 FORMAT(' >>> Some error in reading model file.', CSK13800 1 ' Model probably not useable.') CSK13810 END CSK13820 SUBROUTINE RIGHT(JINDX,KINDX) CSK13830 INCLUDE "csk" CSK13840 I=JINDX CSK13850 LINDEX=KINDX CSK13860 MID=MIDL(I) CSK13870 IA=NODE(I) CSK13880 DO 1 II=IA,MID CSK13890 IF(IFROM(II)-LINDEX) 1,3,1 CSK13900 1 CONTINUE CSK13910 2 WRITE(6 ,900) I,LINDEX,KWAY CSK13920 KWAY=1 CSK13930 KFROM=NODE(I) CSK13940 ITO=NODE(I+1)-1 CSK13950 WRITE(6,910) KFROM,MIDL(I),ITO,(K,IFROM(K),K=KFROM,ITO) CSK13960 910 FORMAT(3I6/(20I6)) CSK13970 RETURN CSK13980 3 ITEMP=IFROM(MID) CSK13990 IFROM(MID)=LINDEX CSK14000 IFROM(II)=ITEMP CSK14010 MIDL(I)=MID-1 CSK14020 RETURN CSK14030 C IBM: CSK14040 ENTRY LEFT(J2,K2) CSK14050 C CDC: CSK14060 C ENTRY LEFT CSK14070 I=J2 CSK14080 LINDEX=K2 CSK14090 MID=MIDL(I)+1 CSK14100 IB=NODE(I+1)-1 CSK14110 DO 10 II=MID,IB CSK14120 IF(IFROM(II) .EQ. LINDEX) GOTO 12 CSK14130 10 CONTINUE CSK14140 KWAY=2 CSK14150 GO TO 2 CSK14160 12 ITEMP=IFROM(MID) CSK14170 IFROM(MID)=LINDEX CSK14180 IFROM(II)=ITEMP CSK14190 MIDL(I)=MID CSK14200 RETURN CSK14210 900 FORMAT(' NODE',I5,' ARC',I5,' LOST ON SHIFT',I4,' LOC ',I4) CSK14220 END CSK14230 SUBROUTINE SAVE CSK14240 INCLUDE "command" CSK14250 CALL OUTPUT(INPERR) CSK14260 IF (INPERR .NE. 0) WRITE (LUOUT,100) CSK14270 RETURN CSK14280 100 FORMAT(' >>> Some error in writing model file.', CSK14290 1 ' (Out of disk space?)' CSK14300 2 /' >>> Model probably not useable.') CSK14310 END CSK14320 C REAL FUNCTION SECOND(III) CSK14330 C CHARACTER*24 DATTIM CSK14340 C REAL*4 EVCPU,ETIME,ETCPU CSK14350 C CALL DATETM(DATTIM,24,EVCPU,ETIME,ETCPU) CSK14360 C SECOND=EVCPU CSK14370 C RETURN CSK14380 C END CSK14390 SUBROUTINE SETARC(IARC,IERR) CSK14400 INCLUDE "csk" CSK14410 INCLUDE "command" CSK14420 CALL NODENO(TOK(1),TOKVAL(1)) CSK14430 CALL NODENO(TOK(2),TOKVAL(2)) CSK14440 IF (TOKVAL(1).EQ.0 .OR. TOKVAL(2).EQ.0) THEN CSK14450 WRITE (LUOUT,1200) MAXN CSK14460 IERR = 1 CSK14470 ELSE CSK14480 IERR = 0 CSK14490 IFROM(IARC)= TOKVAL(1) CSK14500 JTO(IARC) = TOKVAL(2) CSK14510 KOS(IARC) = TOKVAL(3) CSK14520 KSAVE(IARC)= TOKVAL(3) CSK14530 IUB(IARC) = TOKVAL(4) CSK14540 LB(IARC) = TOKVAL(5) CSK14550 FLOZOK = .FALSE. CSK14560 CHGMOD = .TRUE. CSK14570 INFEAS = -1 CSK14580 ENDIF CSK14590 RETURN CSK14600 1200 FORMAT(11X,'>Maximum of',I5,' nodes exceeded. END command<') CSK14610 END CSK14620 SUBROUTINE SOLVE CSK14630 INCLUDE "command" CSK14640 INCLUDE "csk" CSK14650 IF (NARC .GT. 0) THEN CSK14660 WRITE (LUOUT,1000) CSK14670 C START = SECOND() CSK14680 CALL SUPERK CSK14690 C SOLCPU = SECOND() - START CSK14700 WRITE (LUOUT,1010) STAT(INFEAS+2) IF (INFEAS .EQ. 0) WRITE (LUOUT,1020) IZZ CSK14720 RETURN CSK14730 ELSE CSK14740 WRITE (LUOUT,1030) CSK14750 RETURN CSK14760 ENDIF CSK14770 1000 FORMAT(' Begin optimization') CSK14780 1010 FORMAT(' Optimization complete. Problem status: ',A10) 1020 FORMAT(' Optimal solution value:',I10) CSK14810 1030 FORMAT(11X,'>Cannot SOLVE - No arcs exist in current model<') CSK14820 END CSK14830 SUBROUTINE SUPERK CSK14840 C **************************************************************** CSK14850 C SUBROUTINE VERSION OF SUPERK OUT-OF-KILTER NETWORK CODE CSK14860 C AUTHOR: RICHARD S. BARR CSK14870 C REVISED: MAY,1975 CSK14880 C COMMENTS: EQUIVALENT OF 9 ARC-LENGTH ARRAYS REQUIRED CSK14890 C WITH NO EXTERNAL STORAGE. KOS ARRAY RETURNED CSK14900 C WITH MARGINAL, RATHER THAN THE ORIGINAL, COSTS. CSK14910 C **************************************************************** CSK14920 INCLUDE "csk" CSK14930 INCLUDE "command" CSK14940 INFEAS=0 CSK14950 INFIN=8 000 000 CSK14960 IFLOW=0 CSK14970 KLAB=0 CSK14980 KPOT=0 CSK14990 KBRK=0 CSK15000 IZZ=0 CSK15010 IP=0 CSK15020 NUMS=0 CSK15030 IPL=0 CSK15040 MAXA2=MAXA*2 CSK15050 NODES1=NODES+1 CSK15060 ND=INFIN CSK15070 MAXAM1=MAXA-1 CSK15080 DO 5 I=1,NODES1 CSK15090 NODE(I)=0 CSK15100 5 LABL(I)=0 CSK15110 DO 10 M10=1,NARC CSK15120 M = ARCID(M10) CSK15130 N=M+OFFSET CSK15140 I=IFROM(M) CSK15150 J=JTO(M) CSK15160 KOS(M) = KSAVE(M) CSK15170 IF (FLOZOK) THEN CSK15180 IFLOW=KFLOW(M) CSK15190 ELSE CSK15200 IFLOW = 0 CSK15210 ENDIF CSK15220 NODE(I)=NODE(I)+1 CSK15230 NODE(J)=NODE(J)+1 CSK15240 JTO(N)=I CSK15250 KFLOW(M)=IUB(M)-IFLOW CSK15260 KFLOW(N)=IFLOW-LB(M) CSK15270 10 CONTINUE CSK15280 FLOZOK = .TRUE. CSK15290 C IF (CHECK) PAUSE 'ARRAYS SET' CSK15300 C ******************************************************************CSK15310 C CSK15320 C SETUP SECTION CSK15330 C CSK15340 C ******************************************************************CSK15350 KL=1 CSK15360 DO 15 K=1,NODES1 CSK15370 JK=NODE(K) CSK15380 NODE(K)=KL CSK15390 LB(K)=KL CSK15400 KL=JK+KL CSK15410 15 MIDL(K)=KL-1 CSK15420 DO 20 L20=1,NARC CSK15430 L = ARCID(L20) CSK15440 LL=L+OFFSET CSK15450 J=JTO(L) CSK15460 I=JTO(LL) CSK15470 KOST=KOS(L) CSK15480 K=KFLOW(L) CSK15490 LO=-KFLOW(LL) CSK15500 C RIGHT=2 LEFT=1 CSK15510 MAIN=2 CSK15520 MIRROR=2 CSK15530 IF(KOST) 29,29,30 CSK15540 29 IF(K)32,32,31 CSK15550 30 IF(LO)35,36,31 CSK15560 31 MAIN=1 CSK15570 32 IF(KOST) 33,34,34 CSK15580 33 IF(K) 35,36,36 CSK15590 34 IF(LO) 35,36,36 CSK15600 35 MIRROR=1 CSK15610 36 GO TO(43,44),MAIN CSK15620 43 II=LB(I) CSK15630 IFROM(II)=L CSK15640 LB(I)=II+1 CSK15650 GO TO 45 CSK15660 44 II=MIDL(I) CSK15670 IFROM(II)=L CSK15680 MIDL(I)=II-1 CSK15690 45 GO TO(46,47),MIRROR CSK15700 46 II=LB(J) CSK15710 IFROM(II)=LL CSK15720 LB(J)=II+1 CSK15730 GO TO 20 CSK15740 47 II=MIDL(J) CSK15750 IFROM(II)=LL CSK15760 MIDL(J)=II-1 CSK15770 20 CONTINUE CSK15780 C IF (CHECK) PAUSE 'SETUP COMPLETE' CSK15790 C ******************************************************************CSK15800 C CSK15810 C GO - SUPERKILTER CSK15820 C CSK15830 C ******************************************************************CSK15840 C CSK15850 C MAIN LOOP (1000) CSK15860 C CSK15870 DO 1000 MAIN2=1,NARC CSK15880 MAIN = ARCID(MAIN2) CSK15890 MAINM=MAIN+OFFSET CSK15900 DO 1000 MODE99=1,2 CSK15910 MODE=MODE99-1 CSK15920 IF(MODE) 52,52,53 CSK15930 52 II=MAIN CSK15940 JZ=MAINM CSK15950 GO TO 54 CSK15960 53 II=MAINM CSK15970 JZ=MAIN CSK15980 54 CONTINUE CSK15990 IF(KFLOW(II)) 65,55,56 CSK16000 55 IF(KFLOW(JZ)) 63,990,990 CSK16010 56 IF(MODE.NE.0) GO TO 57 CSK16020 IF(KOS(II)) 63,55,55 CSK16030 57 IF(KOS(JZ)) 55,55,63 CSK16040 C IS,IT = START,END NODE NOS, JS,JT = ARC,MIRROR ARC NOS CSK16050 C FOR ARC NEEDING FLOW INCREASE CSK16060 C WANT TO INCREASE FLOW, START LABLEING AT JJ CSK16070 63 IS=JTO(JZ) CSK16080 JS=II CSK16090 IT=JTO(II) CSK16100 JT=JZ CSK16110 GO TO 70 CSK16120 C WANT TO DECREASE FLOW, START LABELING AT II CSK16130 65 IT=JTO(JZ) CSK16140 IS=JTO(II) CSK16150 JS=JZ CSK16160 JT=II CSK16170 C CSK16180 C LABELING PROCEDURE CSK16190 C CSK16200 70 DMPCOD = 'LABELOUT' CSK16210 IF (CHECK) CALL DUMPO(II,DMPCOD) CSK16220 IPL=1 CSK16230 IPLL=1 CSK16240 IPS=0 CSK16250 NUMS=0 CSK16260 LABL(IT)=JS CSK16270 IWV(IPL)=IT CSK16280 84 KLAB=KLAB+1 CSK16290 GO TO 86 CSK16300 85 IF(IPS-IPL)86,200,86 CSK16310 86 IPS=IPS+1 CSK16320 IA=IWV(IPS) CSK16330 IB=NODE(IA) CSK16340 IE=MIDL(IA) CSK16350 IF(IB-IE) 87,87,85 CSK16360 87 DO 90JJ=IB,IE CSK16370 J=IFROM(JJ) CSK16380 NUNODE=JTO(J) CSK16390 IF(LABL(NUNODE)) 90,88,90 CSK16400 88 LABL(NUNODE)=J CSK16410 IPL=IPL+1 CSK16420 IWV(IPL)=NUNODE CSK16430 IF(NUNODE-IS) 90,96,90 CSK16440 90 CONTINUE CSK16450 GO TO 85 CSK16460 C CSK16470 C BREAKTHROUGH BREAKTHROUGH BREAKTHROUGH CSK16480 C CSK16490 96 KBRK=KBRK+1 CSK16500 DMPCOD = 'BREAKTHR' CSK16510 IF (CHECK) CALL DUMPO(II,DMPCOD) CSK16520 97 IALPHA=INFIN CSK16530 C CSK16540 C FIRST RETRACE CSK16550 C CSK16560 C IJ = PREDECESSOR ARC INDEX CSK16570 C JI = MIRROR ARC INDEX CSK16580 C K = LB POINTER CSK16590 C NEXT = PREDECESSOR NODE CSK16600 C CSK16610 K=0 CSK16620 NOW=IS CSK16630 100 IJ=LABL(NOW) CSK16640 K=K+1 CSK16650 JI=IJ-OFFSET CSK16660 IF(JI) 101,101,102 CSK16670 101 JI=IJ+OFFSET CSK16680 IF(KOS(IJ)) 105,105,104 CSK16690 102 IF(KOS(JI)) 104,105,105 CSK16700 104 NET=-KFLOW(JI) CSK16710 LB(K)=NET CSK16720 GO TO 110 CSK16730 105 NET=KFLOW(IJ) CSK16740 LB(K)=NET CSK16750 110 IALPHA=MIN0(IALPHA,NET) CSK16760 NEXT=JTO(JI) CSK16770 IF(NEXT-IS) 111,120,111 CSK16780 111 NOW=NEXT CSK16790 GO TO 100 CSK16800 C CSK16810 C SECOND RETRACE CSK16820 C CSK16830 120 K=0 CSK16840 DMPCOD = 'RETRACE2' CSK16850 IF (CHECK) CALL DUMPO(II,DMPCOD) CSK16860 NOW=IS CSK16870 125 IJ=LABL(NOW) CSK16880 JI=IJ-OFFSET CSK16890 IF(JI) 126,126,127 CSK16900 126 JI=JI+2*OFFSET CSK16910 127 NEXT=JTO(JI) CSK16920 K=K+1 CSK16930 KFLOW(IJ)=KFLOW(IJ)-IALPHA CSK16940 NET=KFLOW(JI) CSK16950 NETNU=NET+IALPHA CSK16960 KFLOW(JI)=NETNU CSK16970 IF(JI.GT.OFFSET) GO TO 1270 CSK16980 IF(KOS(JI)) 128,1271,128 CSK16990 1270 IF(KOS(IJ).NE.0) GO TO 128 CSK17000 1271 IF(NET) 1272,1272,128 CSK17010 1272 IF(NETNU) 128,128,1273 CSK17020 1273 CALL LEFT(NOW,JI) CSK17030 128 IF(LB(K)-IALPHA) 129,1281,129 CSK17040 1281 CALL RIGHT(NEXT,IJ) CSK17050 129 IF(NEXT-IS) 130,150,130 CSK17060 130 NOW=NEXT CSK17070 GO TO 125 CSK17080 C CSK17090 C ERASE LABELS AND GO FOR O-K CHECK CSK17100 C CSK17110 150 DO 155 I=1,IPL CSK17120 J=IWV(I) CSK17130 155 LABL(J)=0 CSK17140 GO TO 54 CSK17150 C CSK17160 C POTENTIAL CHANGE CSK17170 C CSK17180 200 KPOT=KPOT+1 CSK17190 DMPCOD = 'POTL CHG' CSK17200 IF (CHECK) CALL DUMPO(II,DMPCOD) CSK17210 201 KSET=NUMS CSK17220 NEWLAB=0 CSK17230 NUMS=0 CSK17240 IMTHRU=0 CSK17250 MIN=INFIN CSK17260 NEW=NONS CSK17270 NONS=MAXA+1 CSK17280 IF(KSET) 204,204,202 CSK17290 202 IF(NEW-MAXA) 295,295,312 CSK17300 C NON-S (L,L-) SET RECYCLING FILTER CSK17310 295 MAXNEW=MAXA+NEW CSK17320 DO 310 L=NEW,MAXA CSK17330 K=MAXNEW-L CSK17340 KK=LB(K) CSK17350 KKK=JTO(KK) CSK17360 IF(LABL(KKK)) 310,300,310 CSK17370 300 NONS=NONS-1 CSK17380 LB(NONS)=KK CSK17390 310 CONTINUE CSK17400 C S-SET RECYCLING FILTER CSK17410 312 DO 203 K=1,KSET CSK17420 KK=LB(K) CSK17430 KKK=JTO(KK) CSK17440 IF(LABL(KKK)) 203,2021,203 CSK17450 2021 IKK=KK-OFFSET CSK17460 IF(IKK.GT.0) GO TO 2020 CSK17470 IF(KOS(KK)) 2023,2023,2022 CSK17480 2020 IF(KOS(IKK).GE.0) GO TO 2023 CSK17490 MIN=MIN0(MIN,-KOS(IKK)) CSK17500 NUMS=NUMS+1 CSK17510 LB(NUMS)=KK CSK17520 GO TO 203 CSK17530 2022 NUMS=NUMS+1 CSK17540 LB(NUMS)=KK CSK17550 MIN=MIN0(MIN,KOS(KK)) CSK17560 GO TO 203 CSK17570 2023 NONS=NONS-1 CSK17580 LB(NONS)=KK CSK17590 203 CONTINUE CSK17600 204 CONTINUE CSK17610 IF(IPLL-IPL) 2039,2039,2111 CSK17620 C FIND MIN(CBAR) OVER SET S CSK17630 2039 DO 211 LL=IPLL,IPL CSK17640 L=IWV(LL) CSK17650 JMID=MIDL(L)+1 CSK17660 JRT=NODE(L+1)-1 CSK17670 IF(JMID-JRT) 2045,2045,211 CSK17680 2045 DO 210KK=JMID,JRT CSK17690 K=IFROM(KK) CSK17700 I=JTO(K) CSK17710 IF(LABL(I)) 210,2040,210 CSK17720 2040 IF(KFLOW(K)) 206,2041,2041 CSK17730 2041 IKK=K-OFFSET CSK17740 IF(IKK.GT.0) GO TO 2042 CSK17750 IF(KOS(K)) 206,206,205 CSK17760 2042 IF(KOS(IKK).GE.0) GO TO 206 CSK17770 MIN=MIN0(MIN,-KOS(IKK)) CSK17780 NUMS=NUMS+1 CSK17790 LB(NUMS)=K CSK17800 GO TO 210 CSK17810 205 NUMS=NUMS+1 CSK17820 LB(NUMS)=K CSK17830 MIN=MIN0(MIN,KOS(K) ) CSK17840 GO TO 210 CSK17850 206 NONS=NONS-1 CSK17860 LB(NONS)=K CSK17870 210 CONTINUE CSK17880 211 CONTINUE CSK17890 2111 IPLL=IPL+1 CSK17900 IF(NUMS) 212,212,215 CSK17910 212 INFEAS=1 CSK17920 print 21200, MAIN2 21200 format(' Infeasiblily at arc ',i5) call stranded GO TO 1100 CSK17930 C CSK17940 C UPDATE RELATIVE COSTS CSK17950 C CSK17960 C UPDATE COST FOR SET S CSK17970 215 DO 230 I=1,NUMS CSK17980 IJ=LB(I) CSK17990 JI=IJ-OFFSET CSK18000 IF(JI) 216,216,217 CSK18010 216 JI=IJ+OFFSET CSK18020 KOST=KOS(IJ)-MIN CSK18030 KOS(IJ)=KOST CSK18040 IF(KOST) 230,218,230 CSK18050 C (JI = ORIGINAL) CSK18060 217 KOST=KOS(JI)+MIN CSK18070 KOS(JI)=KOST CSK18080 IF(KOST.NE.0) GO TO 230 CSK18090 218 IF(KFLOW(IJ)) 230,230,220 CSK18100 220 NODEB=JTO(IJ) CSK18110 CALL LEFT(JTO(JI),IJ) CSK18120 IF(LABL(NODEB)) 230,223,230 CSK18130 223 LABL(NODEB) =IJ CSK18140 IPL=IPL+1 CSK18150 IWV(IPL)=NODEB CSK18160 IF(NODEB-IS) 230,225,230 CSK18170 225 IMTHRU=1 CSK18180 230 CONTINUE CSK18190 C UPDATE COST FOR NON-S CSK18200 IF(NONS-MAXA) 240,240,345 CSK18210 240 DO 270 I=NONS,MAXA CSK18220 IJ=LB(I) CSK18230 JI=IJ-OFFSET CSK18240 IF(JI) 242,242,244 CSK18250 242 JI=IJ+OFFSET CSK18260 KOSTA=KOS(IJ) CSK18270 KOSTB=KOSTA-MIN CSK18280 KOS(IJ)=KOSTB CSK18290 GO TO 260 CSK18300 C (JI = ORIGINAL) CSK18310 244 KOSTA=-KOS(JI) CSK18320 KOSTB=KOSTA-MIN CSK18330 KOS(JI)=-KOSTB CSK18340 C CHECK FOR MIRROR LEAVING MU STATE CSK18350 C CHECK LATER FOR COMBINING IF-CHECKS COPYOFF CSK18360 260 IF(KOSTA) 270,262,262 CSK18370 262 IF(KOSTB) 264,270,270 CSK18380 264 IF(KFLOW(IJ)) 270,269,269 CSK18390 269 IF(KFLOW(JI)) 270,270,2691 CSK18400 2691 CALL RIGHT(JTO(IJ),JI) CSK18410 270 CONTINUE CSK18420 C OUT-OF-KILTER CHECK CSK18430 345 IF(KFLOW(II))360,350,351 CSK18440 350 IF(KFLOW(JZ)) 360,980,980 CSK18450 351 IF(MODE.NE.0) GO TO 353 CSK18460 IF(KOS(II)) 360,350,350 CSK18470 353 IF(KOS(JZ)) 350,350,360 CSK18480 C BREAKTHROUGH CHECK CSK18490 360 IF(IMTHRU) 361,361,96 CSK18500 361 IF(IPS-IPL) 84,200,84 CSK18510 980 DO 981 I=1,IPL CSK18520 J=IWV(I) CSK18530 981 LABL(J)=0 CSK18540 990 CONTINUE CSK18550 1000 CONTINUE CSK18560 DMPCOD = 'END LOOP' CSK18570 IF (CHECK) CALL DUMPO(II,DMPCOD) CSK18580 IF(KDUAL.GT.0) CALL DUALS CSK18590 1100 DO 1105 I1100=1,NARC CSK18600 I = ARCID(I1100) CSK18610 J=I+OFFSET CSK18620 IFROM(I)=JTO(J) CSK18630 IFLOW=IUB(I)-KFLOW(I) CSK18640 KFLOW(I)=IFLOW CSK18650 IZZ=IZZ+IFLOW*KSAVE(I) CSK18660 1105 LB(I)=IFLOW-KFLOW(J) CSK18670 RETURN CSK18680 END CSK18690 SUBROUTINE TITL CSK18700 LOGICAL GETLIN CSK18710 INCLUDE "csk" CSK18720 INCLUDE "command" CSK18730 IF (.NOT.GETLIN(TITLE,75)) TITLE = ' ' CSK18750 C WRITE (LUOUT,1200) TITLE CSK18760 CHGMOD = .TRUE. CSK18770 RETURN CSK18780 1000 FORMAT(' Please enter the model title:') CSK18790 1100 FORMAT(A60) CSK18800 1200 FORMAT(11X,'Title: ',A60) CSK18810 END CSK18820 SUBROUTINE TOKEN(INCHAR,MAXCHR,TOK,MAXTOK,NTOK,IERR) CSK18830 CHARACTER CH CSK18840 CHARACTER*8 TOK(1) CSK18850 CHARACTER*80 INCHAR CSK18860 LOGICAL MAKING CSK18870 C CSK18880 MAXT=MAXTOK/8 CSK18890 MAKING = .FALSE. CSK18900 NTOK = 0 CSK18910 IERR = 0 CSK18920 DO 10 I=1,MAXCHR CSK18930 CH = INCHAR(I:I) CSK18940 IF (CH.EQ.' ' .OR. CH.EQ.',') THEN CSK18950 IF (MAKING) THEN CSK18960 TOK(NTOK) = INCHAR(N1:N2) CSK18970 MAKING = .FALSE. CSK18980 ENDIF CSK18990 ELSE CSK19000 IF (MAKING) THEN CSK19010 N2 = I CSK19020 ELSE CSK19030 MAKING = .TRUE. CSK19040 IF (NTOK.GE.MAXT) THEN CSK19050 IERR = 8 CSK19060 RETURN CSK19070 ENDIF CSK19080 NTOK = NTOK + 1 CSK19090 N1 = I CSK19100 N2 = I CSK19110 ENDIF CSK19120 ENDIF CSK19130 10 CONTINUE CSK19140 IF (MAKING) TOK(NTOK) = INCHAR(N1:N2) CSK19150 RETURN CSK19160 END CSK19170 LOGICAL FUNCTION TOKARC() CSK19180 INCLUDE "command" CSK19190 TOKARC = .FALSE. CSK19200 IF (NTOKEN .LT. 2) THEN CSK19210 IF (NTOKEN.EQ.1 .AND. TOK(1).EQ.'END') THEN CSK19220 TOKARC = .TRUE. CSK19230 RETURN CSK19240 ELSE CSK19250 WRITE (LUOUT,1000) CSK19260 STOP CSK19270 ENDIF CSK19280 ENDIF CSK19290 IF (NTOKEN .GE. 3) THEN CSK19300 IF (.NOT. TOKNUM(3)) THEN CSK19310 WRITE (LUOUT,1100) TOK(3) CSK19320 STOP CSK19330 ENDIF CSK19340 ELSE CSK19350 TOKVAL(3) = 0 CSK19360 ENDIF CSK19370 IF (NTOKEN .GE. 4) THEN CSK19380 IF (.NOT. TOKNUM(4)) THEN CSK19390 WRITE (LUOUT,1200) TOK(4) CSK19400 STOP CSK19410 ENDIF CSK19420 ELSE CSK19430 TOKVAL(4) = 9 999 999 CSK19440 ENDIF CSK19450 IF (NTOKEN .GE. 5) THEN CSK19460 IF (.NOT. TOKNUM(5)) THEN CSK19470 WRITE (LUOUT,1300) TOK(5) CSK19480 STOP CSK19490 ENDIF CSK19500 ELSE CSK19510 TOKVAL(5) = 0 CSK19520 ENDIF CSK19530 TOKARC = .TRUE. CSK19540 RETURN CSK19550 1000 FORMAT(' >>> At least two node names needed, please reenter arc.')CSK19560 1100 FORMAT(' >>> Non-numeric cost: ',A8,' Please reenter arc.') CSK19570 1200 FORMAT(' >>> Non-numeric upper bound: ',A8, CSK19580 1 ' Please reenter arc.') CSK19590 1300 FORMAT(' >>> Non-numeric lower bound: ',A8, CSK19600 1 ' Please reenter arc.') CSK19610 END CSK19620 CHARACTER FUNCTION YESNO() CSK19630 CHARACTER CH CSK19640 LOGICAL INOK, GETTOK CSK19650 INCLUDE "command" CSK19660 10 WRITE (LUOUT,100) CSK19670 INOK = GETTOK() CSK19680 IF (INOK .AND. .NOT.TOKNUM(1)) THEN CSK19690 YESNO = TOK(1)(1:1) CSK19700 IF (YESNO .EQ. 'Y' .OR. YESNO .EQ. 'N') RETURN CSK19710 ENDIF CSK19720 GOTO 10 CSK19730 100 FORMAT(' Please enter Y(es) or N(o):') CSK19740 110 FORMAT(A1) CSK19750 END CSK19760 SUBROUTINE MSG(CH,N) CSK19770 CHARACTER CH(N) CSK19780 PRINT 100,CH CSK19790 RETURN CSK19800 100 FORMAT(' >>',80A1) CSK19810 END CSK19820 SUBROUTINE SHOW CSK19830 INCLUDE "command" CSK19840 DO 10 I=1,NTOKEN CSK19850 10 PRINT 100,I,TOK(I),TOKNUM(I),TOKVAL(I) CSK19860 RETURN CSK19870 100 FORMAT(I5,2X,A13,L1,I8) CSK19880 END CSK19890 SUBROUTINE DUMPO(IARC,TYPE) CSK19900 CHARACTER*8 TYPE CSK19910 INCLUDE "csk" CSK19920 INCLUDE "command" CSK19930 WRITE(LUOUT,1000)IARC,TYPE CSK19940 DO 10 I=1, NODES CSK19950 WRITE(LUOUT,1010)I,NODNAM(I),NODE(I),MIDL(I),IFROM(I), CSK19960 * LABL(I),IWV(I) CSK19970 10 CONTINUE CSK19980 N1 = NODES+1 CSK19990 N2 = NARC*2 CSK20000 DO 20 I=N1,N2 CSK20010 WRITE(LUOUT,1020) IFROM(I) CSK20020 20 CONTINUE CSK20030 RETURN CSK20040 1000 FORMAT(' AT ARC',I3,' (',A8,')'/ CSK20050 *' I NODNAME NODE MIDL IFROM LABL IWV') CSK20060 1010 FORMAT(I6,2X,A8,6I6) CSK20070 1020 FORMAT(28X,I6) CSK20080 END CSK20090 SUBROUTINE CLRSCR RETURN END subroutine CTI(intoken,nchars,NRR,IVALUE,IDUMMY) character*8 intoken character*1 item NRR = 0 ivalue = 0 isign = +1 i1char = 1 item = intoken(1:1) if (item.eq.'-') then isign = -1 i1char = 2 endif do 10 i=i1char,8 item = intoken(i:i) if(item.ge.'0' .and. item.le.'9') then ivalue = ivalue*10 + (ichar(item)-ichar('0')) NRR = 1 else return endif 10 continue return end subroutine stranded INCLUDE "csk" CSK19920 INCLUDE "command" CSK19930 WRITE(LUOUT,1000) DO 10 I=1, NODES if (NODE(i).gt.MIDL(i)) then print 1100,NODNAM(I) endif 10 CONTINUE CSK19980 return 1000 format(' Nodes without outbound arcs:') 1100 format(4x, A8) end