github.com/PDP-10.stacken
1
0
Fork 0
mirror of https://github.com/PDP-10/stacken.git synced 2026-02-28 17:09:15 +00:00
Code Issues Projects Releases Wiki Activity
Files
master
PDP-10.stacken/files/stacken-tape-backup/dskb:10_7/scdset/scdset.for
Lars Brinkhoff 6e18f5ebef Extract files from tape images. 
Some tapes could not be extracted.
2021-01-29 10:47:33 +01:00

1591 lines
46 KiB
Fortran
Raw Permalink Blame History

This file contains invisible Unicode characters
This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
*SCDSET.FOR - SYSTEM ADMINISTRATOR SCHEDULAR PARAMETER SETTING PROGRAM
*COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1975,1978,1979,1980,1983,1984,1985,1986.
*ALL RIGHTS RESERVED.
*
*
*THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
*ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
*INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
*COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
*OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
*TRANSFERRED.
*
*THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
*AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
*CORPORATION.
*
*DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
*SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
*REVISION HISTORY:
* VERSION 1: MARCH 31 1975 BY MICHAEL TIGHE
*
*EDIT NUMBER REASON
*----------- ------
* 1 QAR #3555: POSSIBLE OVERFLOW IN FUNCTION 7
* 2 IF ACCT(14) IS NEGATIVE, BYTE CALCULATION AT
* LINE (LABEL 100)+2 FAILS. (18848)
* 3 BATCH JOBS DON'T GET SET INTO CORRECT
* SCHED CLASS, SUBR FIXJOB, LINE 41 USES DECIMAL
* INTO GETTAB TBL WHERE OCTAL NEEDED
* VERSION 2: MAY, 1977
* 4 REPLACE NUMERIC FUNCTION SELECTION WITH
* COMMANDS
* VERSION 3: JANUARY, 1978
* 5 ADD FUNCTIONS 11-23 FOR WMU CLASS SCHEDULER
* 6 ALLOW SPACE AS DELIMITER BETWEEN COMMAND AND FUNCTION
*
* 7 ALLOW UPPER AND LOWER CASE IN COMMAND TYPEIN
* 10 (QAR 10-02469) ALLOW NULL COMMANDS WITHOUT ERROR MSG
* VERSION 3A: MARCH, 1979
*
* 11 ALLOW 511 JOBS
* 12 ONE MORE TRY AT EDIT 11
* VERSION 4: MAY, 1983
*
* VERSION 5: FEBRUARY 1985
* 14 ADD FUNCTION 25 FOR HIGH SEGMENT RETENTION TIMES AND FUNCTION
* 26 FOR SETTING CORE LIMITS/GOALS
* 15 ADD FUNCTION 24 TO SUPPORT CHANGING SCHEDULER QUEUE SCAN ORDER
* 16 CHANGE SCANAC TO CALL NEW ROUTINE PROGET (IN SCDEXE.MAC) TO
* RETURN USER PROFILE WHICH CONTAINS SCHED CLASS.
* 17 MAKE MOVSCD CALL NEW ROUTINE NEWSCD (IN SCDEXE.MAC) WHICH
* TELLS ACTDAE TO REREAD SYS:SCDMAP.SYS.
* 20 REMOVE A "DIRECTORY=' '" FROM AN OPEN IN MOVSCD.
* 21 9-AUG-85 DO COPYRIGHTS.
* 22 TEACH SCDSET ABOUT VERSION 6 ACTDAE.SYS
PROGRAM SCDSET
*
* THIS PROGRAM IS A SIMPLE COMMAND LOOP THAT ALLOWS THE
* USER (ASSUMING HE HAS THE PRIVILEGES) TO EXECUTE THE
* SCHED. UUO. THERE IS ONE SUBROUTINE FOR EACH SCHED.
* FUNCTION TO SET UP THE ARRAY D. A IS SET UP BY THE
* MAIN PROGRAM. THE SUBROUTINE THAT EXECUTES THE UUO
* IS A MACRO PROGRAM CALLED SCDEXE. IT TAKES THE COMMON
* DATA AREA FOR ITS ARGUMENT BLOCKS.
*
* THERE ARE OTHER SUBROUTINES THAT DO USEFUL WORK FOR
* THE SYSTEM ADMINISTRATOR.
* MAKMAP GENERATES A SCDMAP.SYS FILE.
* FIXJOB PUTS IT ON SYS AND UPDATES THE SCHEDULER
* CLASS FOR ALL LOGGED IN JOBS
* MOVSCD MOVES A SCDMAP.SYS FILE TO THE SYS AREA
*
*(IT IS STRONGLY SUGGESTED THAT THIS PROGRAM BE RUN IN HPQ)
*
IMPLICIT INTEGER (A-Z)
*
PARAMETER FUNLEN=20 !NUMBER CHARS PER FUN
PARAMETER NOFUNS=27 !NUMBER FUNCTIONS
PARAMETER MINCHR=1 !MIN ABBREVICTION
PARAMETER CMDLEN=20 !NUMBER CHARS PER COMMAND
PARAMETER NOCMDS=9
PARAMETER FL=4 !FUNLEN+4/5
PARAMETER CL=4 !CMDLEN+4/5
*
DIMENSION CLIST(FL,NOFUNS)
DIMENSION CLISTD(3)
DIMENSION CLISTA(FUNLEN,NOFUNS)
DIMENSION DLIST(CL,NOCMDS)
DIMENSION DLISTD(3)
DIMENSION DLISTA(CMDLEN,NOCMDS)
*
DIMENSION SRCSTR(80)
*
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* A = LH OF AC ARGUMENT FOR SCHED. UUO
* B = 0 IF UUO WON, ERROR NUMBER OTHERWISE
* D = THE ARRAY THAT HOLDS THE TABLE FOR THE UUO
* W = CURRENT STATE OF WRITING (=1) OR READING (=0)
* Z = JOBMAX OF THE SYSTEM. D SHOULD BE DIMENSIONED
* LARGER THAN JOBMAX OR HIGHEST CLASS NUMBER
* HCL = HIGHEST CLASS NUMBER FOR THE SYSTEM CURRENTLY
* BEING RUN.
*
* THE FOLLOWING FUNCTIONS ARE INVOKED BY ENTERING
* THE READ OR SET COMMAND FOLLOWED BY THE DESIRED
* FUNCTION (SEPARATED BY A COMMA).
*
CHARACTER*132 CRLF*2,COPY,COPYRI
PARAMETER (CRLF=CHAR(13)//CHAR(10))
PARAMETER (COPY=CRLF//CRLF//'COPYRIGHT (c)'//
1 ' DIGITAL EQUIPMENT CORPORATION 1975,1986.'//
2 CRLF//'ALL RIGHTS RESERVED.'//CRLF//CRLF)
DATA COPYRI/COPY/
DATA (CLIST(I,1),I=1,FL)/'MS INTERVAL '/
DATA (CLIST(I,2),I=1,FL)/'MCU INTERVAL '/
DATA (CLIST(I,3),I=1,FL)/'PRIMARY PERCENTAGES '/
DATA (CLIST(I,4),I=1,FL)/'TIME BASE '/
DATA (CLIST(I,5),I=1,FL)/'CHANNEL UTILIZATION '/
DATA (CLIST(I,6),I=1,FL)/'JOB CLASS '/
DATA (CLIST(I,7),I=1,FL)/'PROT0 '/
DATA (CLIST(I,8),I=1,FL)/'RUNTIME BY CLASS '/
DATA (CLIST(I,9),I=1,FL)/'EXPONENTIAL FACTOR '/
DATA (CLIST(I,10),I=1,FL)/'PROT '/
DATA (CLIST(I,11),I=1,FL)/'DEFAULT CLASS '/
DATA (CLIST(I,12),I=1,FL)/'PROT1 '/
DATA (CLIST(I,13),I=1,FL)/'PROTM '/
DATA (CLIST(I,14),I=1,FL)/'TIME MULTIPLIER '/
DATA (CLIST(I,15),I=1,FL)/'TIME MAXIMUM '/
DATA (CLIST(I,16),I=1,FL)/'SECONDARY ALLOCATION'/
DATA (CLIST(I,17),I=1,FL)/'RESPONSE FAIRNESS '/
DATA (CLIST(I,18),I=1,FL)/'AVG SWAP TIME '/
DATA (CLIST(I,19),I=1,FL)/'BB CLASS '/
DATA (CLIST(I,20),I=1,FL)/'BB SWAP TIME '/
DATA (CLIST(I,21),I=1,FL)/'SCHEDULER FAIRNESS '/
DATA (CLIST(I,22),I=1,FL)/'SWAPPER FAIRNESS '/
DATA (CLIST(I,23),I=1,FL)/'INCORE FAIRNESS '/
DATA (CLIST(I,24),I=1,FL)/'CORE SCHED INTERVAL '/
DATA (CLIST(I,25),I=1,FL)/'QUEUE SCAN ORDER '/
DATA (CLIST(I,26),I=1,FL)/'HI SEG IN CORE TIME '/
DATA (CLIST(I,27),I=1,FL)/'FREE CORE LIMITS '/
DATA (CLISTD(I),I=1,3)/FUNLEN,NOFUNS,MINCHR/
*
DATA (DLIST(I,1),I=1,CL)/'HELP '/
DATA (DLIST(I,2),I=1,CL)/'EXIT '/
DATA (DLIST(I,3),I=1,CL)/'UPDATE JOBS '/
DATA (DLIST(I,4),I=1,CL)/'EDIT '/
DATA (DLIST(I,5),I=1,CL)/'COPY '/
DATA (DLIST(I,6),I=1,CL)/'INPUT '/
DATA (DLIST(I,7),I=1,CL)/'OUTPUT '/
DATA (DLIST(I,8),I=1,CL)/'READ '/
DATA (DLIST(I,9),I=1,CL)/'SET '/
DATA (DLISTD(I),I=1,3)/CMDLEN,NOCMDS,MINCHR/
*
DATA BLANK,COMMA,TAB,ALTMOD/' ',',',' ',"155004020100/
DATA LOWERA,LOWERZ/"605004020100,"751004020100/
*
INU=5
OUTU=5
INOPN=0
OUTOPN=0
DO 10 I=1,NOFUNS
DECODE (FUNLEN,95,CLIST(1,I))(CLISTA(J,I),J=1,FUNLEN)
10 CONTINUE
DO 15 I=1,NOCMDS
DECODE (CMDLEN,95,DLIST(1,I))(DLISTA(J,I),J=1,CMDLEN)
15 CONTINUE
*
A = "15000011 !GETTAB FOR # OF JOBS
CALL TABGET
Z = 128 !A DEFAULT VALUE
IF (B .EQ. 0) Z = (A .AND. "777777) - 1
* THAT SETS Z TO SYSTEM JOBMAX
A = "117000011 !GETTAB FOR # OF SCD CLASSES
CALL TABGET
HCL = 32 !A DEFAULT VALUE
IF (B .EQ. 0) HCL = A
HCL1 = HCL !FOR PRINTOUT
HCL = HCL - 1 !HIGHEST NUM (COUNT UP FROM 0)
* THAT SETS HCL TO SYSTEM CONFIG.
WRITE (OUTU, 99) Z, HCL1
100 IF (INU.NE.5.OR.OUTU.NE.5) WRITE (OUTU, 998)
IF (INU.EQ.5) WRITE (5,98)
READ (INU,97,END=690) (SRCSTR(I),I=1,60)
CALL MAPCSE(SRCSTR,60)
*
*
DO 101 I=1,60
CHR=SRCSTR(I)
IF (CHR.EQ.TAB) SRCSTR(I)=BLANK
IF (CHR.EQ.ALTMOD) SRCSTR(I)=BLANK
IF (CHR.GE.LOWERA.AND.CHR.LE.LOWERZ)
2 SRCSTR(I)=SRCSTR(I)-"200000000000
101 CONTINUE
DO 20 I=1,60
IF (SRCSTR(I) .NE. BLANK) GOTO 30
20 CONTINUE
GOTO 100
30 CMD = STRMCH(DLISTA(1,1),DLISTD(1),SRCSTR(I))
J=I
DO 40 I=I,60
IF (SRCSTR(I) .EQ. COMMA) GOTO 50
40 CONTINUE
DO 45 I=J,60
IF (SRCSTR(I) .EQ. BLANK) GOTO 50
45 CONTINUE
FUN=0
GOTO 80
50 J=I
I=I+1
DO 60 I=I,60
IF (SRCSTR(I) .NE. BLANK) GOTO 70
60 CONTINUE
IF (SRCSTR(J) .EQ. COMMA) GOTO 500
FUN=0
GOTO 80
70 FUN = STRMCH(CLISTA(1,1),CLISTD(1),SRCSTR(I))-1
*
80 GOTO (500,200,205,210,215,220,225,230,235,240), CMD+1
200 WRITE (OUTU,88) ((DLIST(I,J),I=1,CL),J=1,NOCMDS),
1 (CLIST(I,1),I=1,FL),
1 (CLIST(I,3),I=1,FL),
1 (CLIST(I,4),I=1,FL),
1 (CLIST(I,6),I=1,FL),
1 (CLIST(I,7),I=1,FL),
1 (CLIST(I,8),I=1,FL),
1 ((CLIST(I,J),I=1,FL),J=10,NOFUNS)
GOTO 100
205 STOP; GOTO 100
210 CALL FIXJOB; GOTO 100
215 CALL MAKMAP; GOTO 100
220 CALL MOVSCD; GOTO 100
225 W=0; GOTO 600
230 W=1; GOTO 650
235 W=0; GOTO 250
240 W=1
250 A = FUN .OR. (W*"400000)
*
GOTO (500,300,305,310,315,320,325,330,335,340,345,350,
1 355,360,365,370,375,380,385,390,395,400,405,410,415,
2 420,425,430), FUN+2
300 CALL FUN0; GOTO 100
305 CALL FUN1; GOTO 100
310 CALL FUN2; GOTO 100
315 CALL FUN3; GOTO 100
320 CALL FUN4; GOTO 100
325 CALL FUN5; GOTO 100
330 CALL FUN6; GOTO 100
335 CALL FUN7; GOTO 100
340 CALL FUN8; GOTO 100
345 CALL FUN9; GOTO 100
350 CALL FUN10; GOTO 100
355 CALL FUN11; GOTO 100
360 CALL FUN12; GOTO 100
365 CALL FUN13; GOTO 100
370 CALL FUN14; GOTO 100
375 CALL FUN15; GOTO 100
380 CALL FUN16; GOTO 100
385 CALL FUN17; GOTO 100
390 CALL FUN18; GOTO 100
395 CALL FUN19; GOTO 100
400 CALL FUN20; GOTO 100
405 CALL FUN21; GOTO 100
410 CALL FUN22; GOTO 100
415 CALL FUN23; GOTO 100
420 CALL FUN24; GOTO 100
425 CALL FUN25; GOTO 100
430 CALL FUN26; GOTO 100
500 IF (OUTU.NE.5.AND.INU.EQ.5) WRITE (5,96)
WRITE (OUTU,96)
GOTO 100
600 IF (INU .NE. 5) GOTO 625
INU=21
IF (INOPN .EQ. 0) OPEN(UNIT=INU,DEVICE='DSK',
1 FILE='SCDSET.INP',ACCESS='SEQIN',MODE='ASCII')
INOPN=-1
WRITE (OUTU,601)
IF (OUTU .NE. 5) WRITE (5,601)
GOTO 100
625 INU=5
WRITE (OUTU,602)
IF (OUTU .NE. 5) WRITE (5,602)
GOTO 100
650 IF (OUTU .NE. 5) GOTO 675
WRITE (OUTU,603)
OUTU=22
IF (OUTOPN .EQ. 0) OPEN(UNIT=OUTU,DEVICE='DSK',
1 FILE='SCDSET.OUT',ACCESS='SEQOUT',MODE='ASCII')
OUTOPN=-1
WRITE (OUTU,603)
GOTO 100
675 WRITE (OUTU,604)
OUTU=5
WRITE (OUTU,604)
GOTO 100
690 CLOSE(UNIT=INU)
INOPN=0
GOTO 625
601 FORMAT (/, X, 'INPUT IS NOW FROM DSK:SCDSET.INP'/)
602 FORMAT (/, X, 'INPUT IS NOW FROM TTY:'/)
603 FORMAT (/, X, 'OUTPUT IS NOW TO DSK:SCDSET.OUT'/)
604 FORMAT (/, X, 'OUTPUT IS NOW TO TTY:'/)
*
*
88 FORMAT (/, X, 'COMMANDS:',
F /, 4X, 4A5,'- TYPE HELP TEXT',
E /, 4X, 4A5,'- EXIT',
D /, 4X, 4A5,'- UPDATE ALL LOGGED IN JOBS TO THE RIGHT CLASS',
C /, 4X, 4A5,'- MANIPULATE A SCDMAP.SYS FILE',
B /, 4X, 4A5,'- MOVE A SCDMAP.SYS FILE TO THE SYS AREA',
C /, 4X, 4A5,'- CHANGE INPUT FROM TTY: TO DSK:SCDSET.INP',
C /, 4X, 4A5,'- CHANGE OUTPUT FROM TTY: TO DSK:SCDSET.OUT',
A /, 4X, 4A5,'- READ SCHEDULING VARIABLE',
A /, 4X, 4A5,'- SET SCHEDULING VARIABLE',
1 //, X, 'READ/SET FUNCTIONS:'
1 /, 4X, 'TYPE READ OR SET FOLLOWED BY A COMMA AND A',
1 /, 4X, 'FUNCTION FROM THE FOLLOWING LIST',
A /, 4X, 4A5,'- MICRO SCHEDULING INTERVAL',
2 /, 4X, 4A5,'- SYSTEM USAGE PERCENTAGE FOR A SCHEDULER CLASS',
3 /, 4X, 4A5,'- BASE TIME SLICE FOR EITHER RUN QUEUE',
5 /, 4X, 4A5,'- SCHEDULER CLASS FOR SPECIFIC JOBS',
6 /, 4X, 4A5,'- PROT0 (CONSTANT ADDED TO THE MCU)',
7 /, 4X, 4A5,'- RUNTIME FOR EACH CLASS SINCE SYS STARTUP',
9 /, 4X, 4A5,'- PROT (MCU MULTIPLIER)',
A /, 4X, 4A5,'- DEFAULT CLASS AT LOGIN',
A /, 4X, 4A5,'- PROT1 (MCU REQUEUE CONSTANT)',
A /, 4X, 4A5,'- PROTM (MCU MAXIMUM)',
B /, 4X, 4A5,'- TIME SLICE MULTIPLIER AND SCALE FACTOR',
C /, 4X, 4A5,'- TIME SLICE MAXIMUM FOR EITHER RUN QUEUE',
D /, 4X, 4A5,'- SECONDARY ALLOCATION FOR A SCHEDULER CLASS',
1 /, 4X, 4A5,'- FAIRNESS PERCENT FOR RESPONSE VS ACCURACY',
2 /, 4X, 4A5,'- AVERAGE SWAP TIME ESTIMATE',
3 /, 4X, 4A5,'- BACKGROUND BATCH CLASS',
4 /, 4X, 4A5,'- BACKGROUND BATCH SWAP TIME INTERVAL',
5 /, 4X, 4A5,'- SCHEDULER FAIRNESS FACTOR FOR PQ1 VS PQ2',
6 /, 4X, 4A5,'- SWAPPER FAIRNESS FACTOR FOR PQ1 VS PQ2',
7 /, 4X, 4A5,'- SWAPPER FAIRNESS PERCENT FOR INCORE VS OUTCORE',
8 /, 4X, 4A5,'- CORE SCHEDULING INTERVAL',
9 /, 4X, 4A5,'- QUEUE SCAN ORDER (PQ1, PQ2) OR (PQ2, PQ1)',
9 /, 4X, 4A5,'- HIGH SEGMENT RETENTION TIME',
9 /, 4X, 4A5,'- FREE CORE GOALS/LIMITS (PERCENT OF USER CORE)')
95 FORMAT (80A1)
96 FORMAT (' %INPUT ERROR - REENTER OR TYPE HELP')
97 FORMAT(80A1)
98 FORMAT (///, X, '(TOP LEVEL)', /, X,
1 'WHICH FUNCTION DO YOU WANT ', $)
998 FORMAT (/, X, '(TOP LEVEL)', /, X,
1 'WHICH FUNCTION DO YOU WANT ')
99 FORMAT(1X,'SYSTEM ADMINISTRATOR SCHEDULER SETTING PROGRAM',
A ', VERSION 3.',/, X, 'SYSTEM CONFIGURATION IS FOR ', I4,
1 ' JOBS AND ', I2, ' SCHEDULER CLASSES.', //,
2 X, 'SUGGESTION: RUN IN HPQ',/,
3 X, 'TYPE HELP FOR HELP')
END
SUBROUTINE MAPCSE(ARRAY,LENGTH)
IMPLICIT INTEGER (A-Z)
DIMENSION ARRAY(LENGTH)
* CASE FOLDS AN ARRAY IN A1 FORMAT
DO 10 I = 1,LENGTH
IF (ARRAY(I) .LT. 0) ARRAY(I) = ARRAY(I) .AND. "577777777777
10 CONTINUE
RETURN
END
SUBROUTINE TTYMOD
* RETURNS PROGRAM TO INTERACTIVE MODE.
* CALLED ON COPY, EDIT, AND POSSIBLY UPDATE COMMANDS
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
OLDOUT=OUTU
IF (OUTU .EQ. 5) GOTO 100
WRITE (OUTU,604)
OUTU=5
WRITE (OUTU,604)
100 IF (INU .EQ. 5) GOTO 200
WRITE (OUTU,602)
IF (OLDOUT .NE. OUTU) WRITE (OLDOUT,602)
INU=5
200 RETURN
602 FORMAT (/, X, 'INPUT IS NOW FROM TTY:'/)
604 FORMAT (/, X, 'OUTPUT IS NOW TO TTY:'/)
END
SUBROUTINE ERRCON
* HANDLES ERROR REPORTING
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
IF (B .EQ. 0 ) GOTO 110
WRITE (OUTU, 83)
IF ((B .LT. 0) .OR. (B .GT. 14)) GOTO 100
GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14) B
1 WRITE(OUTU,91); GOTO 300
2 WRITE(OUTU,92); GOTO 300
3 WRITE(OUTU,93); GOTO 300
4 WRITE(OUTU,94); GOTO 300
5 WRITE(OUTU,95); GOTO 300
6 WRITE(OUTU,96); GOTO 300
7 WRITE(OUTU,97); GOTO 300
8 WRITE(OUTU,98); GOTO 300
9 WRITE(OUTU,99); GOTO 300
10 WRITE(OUTU,200); GOTO 300
11 WRITE(OUTU,201); GOTO 300
12 WRITE(OUTU,202); GOTO 300
13 WRITE(OUTU,203); GOTO 300
14 WRITE(OUTU,204); GOTO 300
100 WRITE(OUTU,81) B; GOTO 300
110 WRITE(OUTU,80); GOTO 300
300 RETURN
80 FORMAT(//, X, 'DONE', /)
81 FORMAT(X, 'ERROR NUMBER:' ,I8, /)
83 FORMAT(X, 'ERROR:')
91 FORMAT(X, 'ADDRESS CHECK ERROR',/)
92 FORMAT(X, 'BAD FUNCTION NUMBER',/)
93 FORMAT(X, 'BAD JOB NUMBER',/)
94 FORMAT(X, 'NO PRIVILEGES',/)
95 FORMAT(X, 'BAD CLASS NUMBER',/)
96 FORMAT(X, 'BAD QUEUE NUMBER',/)
97 FORMAT(X, 'BAD CHANNEL NUMBER',/)
98 FORMAT(X, 'BAD EXPONENTIAL FACTOR (RANGE: 0-10000.)',/)
99 FORMAT(X, 'ATTEMPT TO MANUALLY SET PROT (MCU MULTIPLIER)',/)
200 FORMAT(X, 'NOT CLASS SCHEDULER',/)
201 FORMAT(X, 'PRIMARY DOES NOT ADD TO 100%',/)
202 FORMAT(X, 'FAIRNESS NOT POSITIVE',/)
203 FORMAT(X, 'ILLEGAL CPU',/)
204 FORMAT(X, 'UNKNOWN SCAN ORDER',/)
END
SUBROUTINE FUN0
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READS OR SETS THE MICRO SCHEDULING INTERVAL
* (THE INTERVAL AT WHICH THE SCHEDULING SCAN TABLES ARE
* REBUILT) THE MEASUREMENT IS IN JIFFIES.
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
101 WRITE (OUTU, 99)
99 FORMAT(X, 'NEW VALUE FOR THE MICRO SCHED. INTERVAL:',
1 ' (IN JIFFIES) ', $)
READ (INU, *) D (0)
IF ( D(0) .LT. 0) RETURN
IF ( D(0) .GT. 10000) RETURN
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'MICRO SCHED. INTERVAL NOW =', I8, ' JIFFIES')
RETURN
END
SUBROUTINE FUN1
*
* READ/SET MINIMUM CORE USE QUOTA ENFORCEMENT INTERVAL
* MEASUREMENT IS IN SECONDS
*
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
WRITE(OUTU, 99)
99 FORMAT (X, 'MCU INTERVAL IS A HISTORICAL FUNCTION',
1 ' NO LONGER IMPLEMENTED')
RETURN
END
SUBROUTINE FUN2
*
* READ/SET CLASS QUOTA'S
* (IE THE PERCENTAGE OF THE SYS A CLASS CAN HAVE)
*
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
GOTO (100,101) W+1
*
100 WRITE (OUTU, 99) HCL
99 FORMAT (X, 'HIGHEST CLASS (0-', I2, ') ', $)
READ (INU, *) D(0)
IF ( D(0) .EQ. -1) RETURN
IF ( D(0) .LT. 0) GOTO 100
IF ( D(0) .GT. HCL) GOTO 100
D(0) = D(0) + 1
DO 110 I=1, D(0)
110 D(I) = 0
CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
DO 120 I=1,D(0)
I1=I-1
F = ' '
IF ( D(I) .GE. 0) GOTO 120
F = 'F'
D(I) = D(I) .AND. "377777777777
120 WRITE (OUTU, 97) I1, D(I), F
97 FORMAT (X, 'CLASS:',I2,' PERCENTAGE OF SYSTEM:',I3, 1X, A1)
RETURN
*
101 TOPCLS = 0
WRITE (OUTU, 96) HCL
96 FORMAT (X, 'GIVE CLASS NUMBER (0-', I2,
1 ') AND THEN THE PERCENTAGE OF RESOURCES (0-100) ',
2 /, 5X, '(-1 TO EXIT)')
150 WRITE (OUTU, 95)
95 FORMAT (/,X,'CLASS: ', $)
READ (INU, *) CVAL
IF (CVAL .EQ. -1) GOTO 200
IF (CVAL .LT. 0) GOTO 150
IF (CVAL .GT. HCL) GOTO 150
155 WRITE (OUTU, 93)
93 FORMAT (X, 'PERCENTAGE OF SYSTEM (0-100): ', $)
READ (INU, *) PVAL
IF (PVAL .EQ. -1) GOTO 200
IF (PVAL .LT. 0) GOTO 155
IF (PVAL .GT. 100) GOTO 155
WRITE (OUTU, 92)
92 FORMAT (X, 'FIXED SWAPIN? (1=YES) ', $)
READ (INU, *) FVAL
IF (FVAL .EQ. -1) GOTO 200
IF (FVAL .NE. 1) FVAL = 0
IF (TOPCLS .LT. 128) TOPCLS = TOPCLS + 1
D(TOPCLS) = FVAL*"400000000000 .OR. CVAL*"1000000 .OR. PVAL
GOTO 150
200 IF (TOPCLS .EQ. 0) RETURN
D(0) = TOPCLS
CALL SCDEXE
CALL ERRCON
RETURN
END
SUBROUTINE FUN3
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET TIME SLICES FOR THE TWO QUEUES.
* MEASURED IN MILLISECONDS
*
IF (W .EQ. 0) GOTO 200
100 WRITE (OUTU, 99)
99 FORMAT (X, 'CHANGE BASE TIME SLICE OF WHICH PQ (1-2) ', $)
READ (INU, *) PVAL
IF (PVAL .EQ. -1) RETURN
IF ( PVAL .LT. 1) GOTO 100
IF ( PVAL .GT. 2) GOTO 100
105 WRITE (OUTU, 98) PVAL
98 FORMAT (X, 'BASE TIME SLICE FOR PQ', I1,
1 ' (IN MILLISECONDS) ', $)
READ (INU, *) TVAL
IF (TVAL .EQ. -1) RETURN
IF (TVAL .LT. 0) GOTO 105
IF (TVAL .GT. 10000) GOTO 105
D(1) = ( PVAL * "1000000 ) .OR. TVAL
D(0) = 1
CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97)
97 FORMAT (X, 'NOW ATTEMPTING TO READ IN BASE TIME SLICES')
200 A = A .AND. "377777 !GET RID OF LEFTOVER WRITE BIT
D(0) = 2; D(1)=0; D(2)=0
CALL SCDEXE
CALL ERRCON
* LEAVE PRINTOUT EVEN IF ERROR, HE MIGHT WANT IT
I1=1; I2=2
WRITE (OUTU, 95) I1, D(1), I2, D(2)
95 FORMAT (/,X, 'BASE TIME SLICE FOR PQ', I1, ' IS NOW ', I8,
1 ' MILLISECONDS.')
RETURN
END
SUBROUTINE FUN4
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET DESIRED CHANNEL USAGE FUNCTION
*
WRITE (OUTU, 99)
99 FORMAT (X, 'CHANNEL UTILIZATION IS A HISTORICAL FUNCTION',
1 ' NO LONGER IMPLEMENTED')
RETURN
END
SUBROUTINE FUN5
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET EACH JOB'S CLASS
*
IF (W .EQ. 1) GOTO 200
50 WRITE (OUTU, 99) Z
99 FORMAT (X, 'HIGHEST JOB (1-', I4, ') ', $)
READ (INU, *) D(0)
IF ( D(0) .EQ. -1) RETURN
IF ( D(0) .LE. 0) GOTO 50
IF ( D(0) .GT. Z) GOTO 50
DO 100 I=1, D(0)
100 D(I)=0
CALL SCDEXE
CALL ERRCON
* LET ERROR GO, HE WANTS TO SEE TYPE OUT
DO 110 I=1, D(0)
SAVEA = A !PRESERVE A
A = I * "1000000 !JOB NUMBER IN LEFT HALF
CALL TABGET !JOB STATUS FOR JOB I
IF ((A .AND. "040000000000) .NE. 0) WRITE (OUTU, 97) I, D(I)
* IF JOB NUMBER NOT ASSIGNED, DON'T PRINT
97 FORMAT (X, 'JOB NUMBER', I3, ' IS IN CLASS', I3)
110 CONTINUE
A = SAVEA !RESTORE A (FOR THE HECK OF IT)
RETURN
*
*
200 WRITE (OUTU, 96)
96 FORMAT(//,X, '(-1 MEANS QUIT, 0 MEANS YOURSELF) ', $)
230 WRITE (OUTU, 94)
94 FORMAT (//, X, 'WHICH JOB ', $)
READ (INU, *) J
IF (J .LT. 0) RETURN
IF (J .EQ. 0) GOTO 210
IF (J .GT. Z) GOTO 230
J = J * "1000000
GOTO 220
210 J = "777777000000
220 WRITE (OUTU, 95) HCL
95 FORMAT (X, 'WHICH CLASS (0-', I2, ') ', $)
READ (INU, *) CLAS
IF (CLAS .EQ. -1) RETURN
IF ((CLAS .LT. 0) .OR. (CLAS .GT. HCL)) GOTO 220
D(0) = 1
D(1) = J .OR. CLAS
CALL SCDEXE
CALL ERRCON
GOTO 230
END
SUBROUTINE FUN6
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET PROT0 (CONSTANT ADDED TO MCU)
* MEASURED IN MICROSECONDS
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X, 'NEW VALUE FOR PROT0 (IN MICROSECONDS) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'NEW VALUE OF PROT0 IS', I8, ' MICROSECONDS')
RETURN
END
SUBROUTINE FUN7
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ RUNTIME SINCE STARTUP OF EACH CLASS
* MEASURED IN JIFFIES. ALSO PRINTS OUT THE PERCENTAGE
* OF RUNTIME FOR EACH CLASS SINCE LAST CLASS QUOTA
* WAS CHANGED
*
SAVEA = A
A = "13000115 !GETTAB VALUE FOR SYS TIME
CALL TABGET
SUM = 1 !DEFAULT
IF ((B .NE. 0) .OR. (A .EQ. 0)) GOTO 100
SUM = A !STORE ANSWER IN SUM
100 A = SAVE A !RESTORE A
WRITE (OUTU, 99) HCL
99 FORMAT (X, 'HIGHEST CLASS (0- ', I2, ') ', $)
READ (INU, *) D(0)
IF ( D(0) .LT. 0) RETURN
IF ( D(0) .GT. HCL) RETURN
D(0) = D(0) + 1
DO 150 I=1, D(0)
150 D(I)=0
CALL SCDEXE
CALL ERRCON
* LET ERROR GO, HE WANTS TO SEE IT
DO 300 I = 1, D(0)
I1 = I-1
PERCNT = D(I) * 100 / SUM
300 WRITE (OUTU, 97) I1, D(I), PERCNT
97 FORMAT (X, 'RUNTIME SINCE STARTUP BY CLASS', I3, ' IS ', I8,
1 ' JIFFIES (', I3, ' PERCENT)')
RETURN
END
SUBROUTINE FUN8
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET EXPONENTIAL FACTOR (IE DEPENDANCE ON THE PAST)
* IN THE RANGE 0-10000
*
WRITE (OUTU, 99)
99 FORMAT (X, 'EXPONENTIAL FACTOR IS A HISTORICAL FUNCTION',
1 ' NO LONGER IMPLEMENTED')
RETURN
END
SUBROUTINE FUN9
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET VALUE OF PROT (MCU MULTIPLIER)
* MEASURED IN MICROSECONDS
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X, 'NEW VALUE FOR PROT (IN MICROSECONDS) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'NEW VALUE OF PROT IS ', I8, ' MICROSECONDS')
RETURN
END
SUBROUTINE FUN10
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET VALUE OF DEFCLS (DEFAULT CLASS)
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X, 'NEW VALUE FOR DEFAULT CLASS ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'NEW DEFAULT CLASS IS', I4)
RETURN
END
SUBROUTINE FUN11
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET PROT1 (MCU CONSTANT USED ON REQUEUE)
* MEASURED IN MICROSECONDS
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X, 'NEW VALUE FOR PROT1 (IN MICROSECONDS) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'NEW VALUE OF PROT1 IS', I8, ' MICROSECONDS')
RETURN
END
SUBROUTINE FUN12
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET VALUE OF PROTM (MCU MAXIMUM)
* MEASURED IN MICROSECONDS
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X, 'NEW VALUE FOR PROTM (IN MICROSECONDS) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'NEW VALUE OF PROTM IS ', I8, ' MICROSECONDS')
RETURN
END
SUBROUTINE FUN13
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET TIME SLICE MULTIPLIERS FOR THE TWO QUEUES.
* MEASURED IN MILLISECONDS
* READ/SET SCALE FACTOR (ABSOLUTE NUMBER)
*
IF (W .EQ. 0) GOTO 200
100 WRITE (OUTU, 99)
99 FORMAT (X, 'CHANGE SCALE FACTOR (3) OR'/
1 X, 'CHANGE TIME SLICE MULTIPLIER OF WHICH PQ (1-2) ', $)
READ (INU, *) PVAL
IF (PVAL .EQ. -1) RETURN
IF ( PVAL .LT. 1) GOTO 100
IF ( PVAL .GT. 3) GOTO 100
IF ( PVAL .EQ. 3) GOTO 150
105 WRITE (OUTU, 98) PVAL
98 FORMAT (X, 'TIME SLICE MULTIPLIER FOR PQ', I1,
1 ' (IN MILLISECONDS) ', $)
READ (INU, *) TVAL
IF (TVAL .EQ. -1) RETURN
IF (TVAL .LT. 0) GOTO 105
IF (TVAL .GT. 10000) GOTO 105
GOTO 170
150 WRITE (OUTU, 96)
96 FORMAT (X, 'SCALE FACTOR FOR TIME SLICE MULTIPLIERS ', $)
READ (INU, *) TVAL
IF (TVAL .EQ. -1) RETURN
IF (TVAL .LE. 0) GOTO 150
IF (TVAL .GT. 1000) GOTO 150
170 D(1) = ( PVAL * "1000000 ) .OR. TVAL
D(0) = 1
CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97)
97 FORMAT (X, 'NOW ATTEMPTING TO READ IN TIME SLICE MULTIPLIERS')
200 A = A .AND. "377777 !GET RID OF LEFTOVER WRITE BIT
D(0) = 3; D(1)=0; D(2)=0; D(3)=0
CALL SCDEXE
CALL ERRCON
* LEAVE PRINTOUT EVEN IF ERROR, HE MIGHT WANT IT
I1=1; I2=2
WRITE (OUTU, 95) I1, D(1), I2, D(2)
95 FORMAT (/,X, 'TIME SLICE MULTIPLIER FOR PQ', I1, ' IS NOW ', I8,
1 ' MILLISECONDS.')
WRITE (OUTU, 94) D(3)
94 FORMAT (/X,'SCALE FACTOR FOR TIME SLICE MULTIPLIERS IS NOW', I8)
RETURN
END
SUBROUTINE FUN14
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET TIME SLICE MAXIMA FOR THE TWO QUEUES.
* MEASURED IN MILLISECONDS
*
IF (W .EQ. 0) GOTO 200
100 WRITE (OUTU, 99)
99 FORMAT (X, 'CHANGE TIME SLICE MAXIMUM OF WHICH PQ (1-2) ', $)
READ (INU, *) PVAL
IF (PVAL .EQ. -1) RETURN
IF ( PVAL .LT. 1) GOTO 100
IF ( PVAL .GT. 2) GOTO 100
105 WRITE (OUTU, 98) PVAL
98 FORMAT (X, 'TIME SLICE MAXIMUM FOR PQ', I1,
1 ' (IN MILLISECONDS) ', $)
READ (INU, *) TVAL
IF (TVAL .EQ. -1) RETURN
IF (TVAL .LT. 0) GOTO 105
IF (TVAL .GT. 10000) GOTO 105
D(1) = ( PVAL * "1000000 ) .OR. TVAL
D(0) = 1
CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97)
97 FORMAT (X, 'NOW ATTEMPTING TO READ IN TIME SLICE MAXIMA')
200 A = A .AND. "377777 !GET RID OF LEFTOVER WRITE BIT
D(0) = 2; D(1)=0; D(2)=0
CALL SCDEXE
CALL ERRCON
* LEAVE PRINTOUT EVEN IF ERROR, HE MIGHT WANT IT
I1=1; I2=2
WRITE (OUTU, 95) I1, D(1), I2, D(2)
95 FORMAT (/,X, 'TIME SLICE MAXIMUM FOR PQ', I1, ' IS NOW ', I8,
1 ' MILLISECONDS.')
RETURN
END
SUBROUTINE FUN15
*
* READ/SET SECONDARY ALLOCATIONS
* (IE THE RELATIVE AMOUNT OF LEAVINGS A CLASS CAN HAVE)
*
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
GOTO (100,101) W+1
*
100 WRITE (OUTU, 99) HCL
99 FORMAT (X, 'HIGHEST CLASS (0-', I2, ') ', $)
READ (INU, *) D(0)
IF ( D(0) .EQ. -1) RETURN
IF ( D(0) .LT. 0) GOTO 100
IF ( D(0) .GT. HCL) GOTO 100
D(0) = D(0) + 1
DO 110 I=1, D(0)
110 D(I) = 0
CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
DO 120 I=1,D(0)
I1=I-1
120 WRITE (OUTU, 97) I1, D(I)
97 FORMAT (X, 'CLASS:',I2,' SECONDARY ALLOCATION:',I5)
RETURN
*
101 TOPCLS = 0
WRITE (OUTU, 96) HCL
96 FORMAT (X, 'GIVE CLASS NUMBER (0-', I2,
1 ') AND THEN THE SECONDARY ALLOCATION (0-1000) ',
2 /, 5X, '(-1 TO EXIT)')
150 WRITE (OUTU, 95)
95 FORMAT (/,X,'CLASS: ', $)
READ (INU, *) CVAL
IF (CVAL .EQ. -1) GOTO 200
IF (CVAL .LT. 0) GOTO 150
IF (CVAL .GT. HCL) GOTO 150
155 WRITE (OUTU, 93)
93 FORMAT (X, 'SECONDARY ALLOCATION: ', $)
READ (INU, *) PVAL
IF (PVAL .EQ. -1) GOTO 200
IF (PVAL .LT. 0) GOTO 155
IF (PVAL .GT. 10000) GOTO 155
IF (TOPCLS .LT. 128) TOPCLS = TOPCLS + 1
D(TOPCLS) = CVAL*"1000000 .OR. PVAL
GOTO 150
200 IF (TOPCLS .EQ. 0) RETURN
D(0) = TOPCLS
CALL SCDEXE
CALL ERRCON
RETURN
END
SUBROUTINE FUN16
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET SCDJIL (RESPONSE FAIRNESS PERCENTAGE)
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X,
1 'NEW PERCENTAGE FOR RESPONSE FAIRNESS FACTOR (1-100) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'RESPONSE FAIRNESS FACTOR IS NOW', I4, '%')
RETURN
END
SUBROUTINE FUN17
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET SWAP TIME ESTIMATE
* MEASURED IN JIFFIES
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X, 'NEW SWAP TIME ESTIMATE (IN JIFFIES) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'AVG SWAP TIME ESTIMATE IS NOW', I4, ' JIFFIES')
RETURN
END
SUBROUTINE FUN18
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET BACKGROUND BATCH CLASS
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X, 'NEW BACKGROUND BATCH CLASS (-1 FOR NONE) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'BACKGROUND BATCH IS NOW CLASS', I4)
RETURN
END
SUBROUTINE FUN19
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET BACKGROUND BATCH SWAP TIME
* MEASURED IN JIFFIES
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X,
1 'NEW BACKGROUND BATCH SWAP INTERVAL (IN JIFFIES) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X,
1 'BACKGROUND BATCH SWAP INTERVAL IS NOW', I8, ' JIFFIES')
RETURN
END
SUBROUTINE FUN20
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET SCHEDULER FAIRNESS FACTOR
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X,
1 'NEW SCHEDULER FAIRNESS FACTOR (1-1000) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'SCHEDULER FAIRNESS FACTOR IS NOW', I5)
RETURN
END
SUBROUTINE FUN21
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET SWAPPER FAIRNESS FACTOR
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X,
1 'NEW SWAPPER FAIRNESS FACTOR (1-1000) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'SWAPPER FAIRNESS FACTOR IS NOW', I5)
RETURN
END
SUBROUTINE FUN22
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET INCORE FAIRNESS FACTOR FOR SWAP IN
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X,
1 'NEW PERCENTAGE FOR INCORE FAIRNESS FACTOR (0-100) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'INCORE FAIRNESS FACTOR IS NOW', I4, '%')
RETURN
END
SUBROUTINE FUN23
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READ/SET CORE SCHEDULING INTERVAL FOR DEMAND SCHEDULING OF CORE
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X,
1 'NEW CORE SCHEDULING INTERVAL (IN SECONDS) ', $)
READ (INU, *) D(0)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'CORE SCHEDULING INTERVAL IS NOW', I5, ' SECONDS')
RETURN
END
SUBROUTINE FUN24
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READS OR SETS THE SCHEDULER QUEUE SCAN ORDER
*
D(0) = 1
IF (W .EQ. 0) GOTO 100
WRITE (OUTU, 99)
99 FORMAT (X,
1 'FOR QUEUE SCAN ORDER, ANSWER 0 FOR (PQ1,PQ2), 1 FOR (PQ2,PQ1)'/
1 ' ENTER CPU NUMBER, QUEUE SCAN ORDER ', $)
READ (INU, *) I,J
D(1) = "1000000*I + J
CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
RETURN
100 I = A
A = "134000011
*
* GET NUMBER OF CPUS
*
CALL TABGET
IF (B .NE. 0) GOTO 300
D(0) = A
A = I
CALL SCDEXE
IF (B .NE. 0) GOTO 300
A = D(0) - 1
DO 200 I = 0, A
WRITE (OUTU, 98) I
98 FORMAT(X, 'ON CPU',I1, ', THE QUEUE SCAN ORDER IS '$)
IF (D(I+1) .EQ. 0) WRITE (OUTU, 97)
97 FORMAT(X,'(PQ1,PQ2)')
IF (D(I+1) .EQ. 1) WRITE (OUTU, 96)
96 FORMAT(X,'(PQ2,PQ1)')
200 CONTINUE
300 CALL ERRCON
RETURN
END
SUBROUTINE FUN25
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READS OR SETS THE HIGH SEGMENT RETENTION TIME
* (THE TIME WHICH A DORMANT OR IDLE HIGH SEGMENT WILL
* STAY AROUND BEFORE IT IS DELETED) THE MEASUREMENT IS
* IN JIFFIES.
*
D(0) = 0
IF (W .EQ. 0) GOTO 100
101 WRITE (OUTU, 99)
99 FORMAT(X, 'NEW VALUE FOR THE HIGH SEGMENT RETENTION TIME:',
1 ' (IN JIFFIES) ', $)
READ (INU, *) D (0)
IF ( D(0) .LT. 0) RETURN
IF ( D(0) .GT. 10000) RETURN
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0)
97 FORMAT (X, 'HIGH SEGMENT RETENTION TIME NOW =', I8, ' JIFFIES')
RETURN
END
SUBROUTINE FUN26
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* READS OR SETS THE PERCENTAGE OF USER CORE WHICH THE SWAPPER
* TRIES TO KEEP FREE BY SWAPPING OUT JOBS WHICH ARE IN LONG
* TERM WAIT.
*
D(0) = 1
IF (W .EQ. 0) GOTO 100
101 WRITE (OUTU, 99)
99 FORMAT(X, 'NEW VALUE FOR THE FREE CORE GOAL:',
1 ' (PERCENT OF USER CORE) ', $)
READ (INU, *) D (0)
IF ( D(0) .LT. 0) RETURN
IF ( D(0) .GT. 10000) RETURN
WRITE (OUTU, 98)
98 FORMAT(X, 'NEW VALUE FOR THE FREE CORE LIMIT:',
1 ' (PERCENT OF USER CORE) ', $)
READ (INU, *) D (1)
100 CALL SCDEXE
CALL ERRCON
IF (B .NE. 0) RETURN
WRITE (OUTU, 97) D(0),D(1)
97 FORMAT (X, 'FREE CORE GOAL NOW =', I8, ' (PERCENT OF USER CORE)',
1 /X, 'FREE CORE LIMIT NOW =', I8, ' (PERCENT OF USER CORE)')
RETURN
END
SUBROUTINE MAKMAP
IMPLICIT INTEGER (A-Z)
*
* THIS FUNCTION ALLOWS THE SYSTEM ADMINISTRATOR
* TO INTERACTIVELY BUILD A SCDMAP.SYS FILE
*
PARAMETER FUNLEN=10 !NUMBER CHARS PER FUN
PARAMETER NOFUNS=7 !NUMBER FUNCTIONS
PARAMETER MINCHR=1 !MIN ABBREVICTION
PARAMETER FL=2 !FUNLEN+4/5
*
COMMON ADUM, BDUM, DDUM, WDUM, ZDUM, HCLDUM, INU, OUTU
DIMENSION DDUM(0:512)
DIMENSION M(0:1023), M1(0:255)
DIMENSION SRCSTR(80)
DIMENSION CLIST(FL,NOFUNS)
DIMENSION CLISTD(3)
DIMENSION CLISTA(FUNLEN,NOFUNS)
*
DATA (CLIST(I,1),I=1,FL)/'HELP '/
DATA (CLIST(I,2),I=1,FL)/'EXIT '/
DATA (CLIST(I,3),I=1,FL)/'READ '/
DATA (CLIST(I,4),I=1,FL)/'WRITE '/
DATA (CLIST(I,5),I=1,FL)/'RANGE '/
DATA (CLIST(I,6),I=1,FL)/'ONE CLASS'/
DATA (CLIST(I,7),I=1,FL)/'TYPE '/
*
DATA (CLISTD(I),I=1,3)/FUNLEN,NOFUNS,MINCHR/
*
DATA BLANK,COMMA/' ',', '/
*
CALL TTYMOD !RETURN TO CONVERSATIONAL MODE
DO 10 I=1,NOFUNS
DECODE (FUNLEN,9999,CLIST(1,I))(CLISTA(J,I),J=1,FUNLEN)
10 CONTINUE
9999 FORMAT (80A1)
*
WRITE (OUTU, 99)
99 FORMAT (//,X,'MAKMAP SUBFUCTION: MANIPULATE A SCDMAP.SYS FILE',
1 /, 5X, 'TYPE HELP FOR HELP')
100 WRITE (OUTU, 98)
98 FORMAT (/, X, '(MAKMAP LEVEL)', /, X, 'WHAT FUNCTION ', $)
READ (INU,196) (SRCSTR(I),I=1,80)
196 FORMAT (80A1)
CALL MAPCSE(SRCSTR,80)
DO 20 I=1,60
IF (SRCSTR(I) .NE. BLANK) GOTO 30
20 CONTINUE
GOTO 100
30 F=STRMCH(CLISTA(1,1),CLISTD(1),SRCSTR(I))
IF (F .LT. 3) GOTO 110
105 WRITE (OUTU, 86)
86 FORMAT (X, 'WHICH MAP (0=TIMESHARE, 1=BATCH) ', $)
READ (INU,*) TB
IF (TB .EQ. -1) GOTO 100
IF (TB .LT. 0) GOTO 105
IF (TB .GT. 1) GOTO 105
110 GOTO (1000,9980, 9990, 10000, 10010, 10020, 10030, 10040) F+1
**************************************************
* TYPE OUT HELP TEXT
*
9980 WRITE (OUTU, 97) ((CLIST(I,J),I=1,FL),J=1,NOFUNS)
97 FORMAT (X, 'FUNCTION:',
1 /, 4X, 2A5, '- TYPE THIS TEXT',
2 /, 4X, 2A5, '- EXIT',
3 /, 4X, 2A5, '- READ IN A SCDMAP.SYS FILE FOR MODIFICATION',
4 /, 4X, 2A5, '- WRITE OUT CURRENT DATA AS A SCDMAP.SYS FILE',
5 /, 4X, 2A5, '- CHANGE A RANGE OF SCHED TYPES TO A CLASS',
6 /, 4X, 2A5, '- CHANGE ONE SCHED TYPE TO A CLASS',
7 /, 4X, 2A5, '- TYPE OUT A RANGE OF TYPES AND THEIR CLASSES',//)
GOTO 100
**************************************************
* GO BACK TO TOP LEVEL
*
9990 RETURN
**************************************************
1000 WRITE (OUTU,9998)
GOTO 100
9998 FORMAT (' %INPUT ERROR, REENTER OR TYPE HELP')
**************************************************
* READ IN A SCDMAP.SYS FILE FOR MODIFICATION
*
10000 DIRECT= 'SEQIN' ; GOTO 10011
10001 READ (20,ERR=10003) M1
CLOSE (UNIT=20)
DO 10002 I=0, 255
M(I*4+0) = ( M1(I) / "1000000000) .AND. "777
M(I*4+1) = ( M1(I) / "1000000) .AND. "777
M(I*4+2) = ( M1(I) / "1000) .AND. "777
10002 M(I*4+3) = M1(I) .AND. "777
WRITE (OUTU, 96)
96 FORMAT (/, X, 'INPUT COMPLETE, FILE CLOSED',/)
GOTO 100
10003 WRITE (OUTU, 88)
88 FORMAT (X, 'ERROR ON INPUT FILE')
CLOSE (UNIT=20)
GOTO 100
**************************************************
* WRITE OUT CURRENT DATA AS A SCDMAP.SYS FILE
*
10010 DIRECT = 'SEQOUT'
10011 OPEN (UNIT=20, ACCESS=DIRECT, MODE='DUMP',
1 DEVICE='DSK', FILE='SCDMAP.SYS', DIRECTORY='1,2', DIALOG)
IF (DIRECT .EQ. 'SEQIN') GOTO 10001
DO 10012 I=0, 255
M1(I) = ( ("777 .AND. M(I*4+0) ) * "1000000000) .OR.
1 ( ("777 .AND. M(I*4+1) ) * "1000000) .OR.
2 ( ("777 .AND. M(I*4+2) ) * "1000) .OR.
3 ( "777 .AND. M(I*4+3) )
10012 CONTINUE
WRITE (20, ERR=10013) M1
CLOSE (UNIT=20)
WRITE (OUTU, 95)
95 FORMAT (/, X, 'OUTPUT COMPLETE, FILE CLOSED', /)
GOTO 100
10013 WRITE (OUTU, 87)
87 FORMAT (X, 'ERROR ON OUTPUT FILE')
CLOSE (UNIT=20)
GOTO 100
**************************************************
**************************************************
* CHANGE A RANGE OF SCD TYPES TO A CLASS
*
10020 WRITE (OUTU, 94)
94 FORMAT (X, 'WHAT RANGE (SEPARATE BY COMMAS) (0,511) ', $)
READ (INU, *) R1, R2
IF ((R1 .LT. 0) .OR. (R2 .LT. 0)) GOTO 100
IF ((R1 .GT. 511) .OR. (R2 .GT. 511)) GOTO 100
IF (R1 .LT. R2) GOTO 10021
R3=R1; R1=R2; R2=R3
10021 WRITE (OUTU, 93) R1, R2
93 FORMAT (X, 'SAME CLASS FOR ', I3, ' THRU ', I3, ' (1=YES) ', $)
READ (INU, *) YESNO
IF (YESNO .NE. 1) YESNO = 0
DO 10022 I=R1, R2
IF ((I .GT. R1) .AND. (YESNO .EQ. 1)) GOTO 10022
WRITE (OUTU, 92) I
92 FORMAT (X, 'TYPE: ', I3, ' CLASS: ', $)
READ (INU, *) CLASS
10022 M(I + (TB*512)) = CLASS
GOTO 100
**************************************************
* CHANGE ONE SCD TYPE TO A CLASS
*
10030 WRITE (OUTU, 91)
91 FORMAT (X, 'GIVE TYPE AND CLASS SEPARATED BY COMMAS ', $)
READ (INU, *) R1, R2
IF ((R1 .LT. 0) .OR. (R1 .GT. 511)) GOTO 100
IF ((R2 .LT. 0) .OR. (R2 .GT. 31)) GOTO 100
M(R1 + (TB*512)) = R2
GOTO 100
**************************************************
* TYPE OUT A RANGE OF TYPES AND THEIR CLASSES
*
10040 WRITE (OUTU, 90)
90 FORMAT (X, 'WHAT RANGE (SEPARATE BY COMMAS) (0,511) ', $)
READ (INU, *) R1, R2
IF ((R1 .LT. 0) .OR. (R2 .LT. 0)) GOTO 100
IF ((R1 .GT. 511) .OR. (R2 .GT. 511)) GOTO 100
IF (R1 .LE. R2) GOTO 10041
R3=R1; R1=R2; R2=R3
10041 WD='TMSHR'
IF (TB .NE. 0) WD = 'BATCH'
DO 10042 I=R1, R2
II=I+(TB*512)
10042 WRITE (OUTU, 89) I, WD, M(II)
89 FORMAT (X, 'SCD TYPE ', I4, 2X, A5, ' MAPS TO CLASS ', I2)
GOTO 100
**************************************************
END
SUBROUTINE FIXJOB
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512), M(0:1023), M1(0:255)
*
WRITE (OUTU, 97)
97 FORMAT (X, 'DO YOU WISH TO MOVE A SCDMAP.SYS FILE TO SYS:',
1 ' (1=YES) ', $)
READ (INU, *) YESNO
IF (YESNO .EQ. 1) CALL MOVSCD !HAD TO REMIND HIM.
OPEN (UNIT=20, DEVICE='SYS', FILE='SCDMAP.SYS', ACCESS='SEQIN',
1 MODE='DUMP')
READ (20) M1
DO 100 I=0, 255
M ((I*4)+0) = (M1(I) / "1000000000) .AND. "777
M ((I*4)+1) = (M1(I) / "1000000) .AND. "777
M ((I*4)+2) = (M1(I) / "1000) .AND. "777
100 M ((I*4)+3) = (M1(I)) .AND. "777
CLOSE (UNIT=20)
CALL MYJOB
ME = A
*
* NOW THAT WE HAVE READ IN THE CURRENT MAP,
* WE SCAN ALL LOGGED IN JOBS AND RESET THEIR CLASS
* FROM THE TYPE STORED IN ACCT.SYS. THE ONLY JOBS
* SKIPPED ARE [2,5] JOBS AND THIS JOB. BATCH JOBS
* GET THE VALUE FROM THE BATCH MAP.
*
DO 200 I=1, Z
IF (I .EQ. ME) GOTO 200 !IF MY JOB THEN SKIP IT
A = I * "1000000 + 2 !GETTAB AC FOR JOB I'S PPN
CALL TABGET !DO THE GETTAB
IF (B .NE. 0) GOTO 200 !IF ERROR THEN NO JOB
IF (A .EQ. 0) GOTO 200 !IF ZERO PPN, NO JOB
IF (A .EQ. "2000005) GOTO 200 !IF PPN = [2,5] SKIP IT
PPN = A !SAVE A (ITS THE PPN)
A = I*"1000000 + "40 !GETTAB FOR BATCH STATUS WORD
CALL TABGET
TB = 0 !DEFAULT TO NOT BATCH
IF (B .NE. 0) GOTO 150 !GETTAB FAILED??
IF ((A .AND. "200000000) .NE. 0) TB = 1 !IT IS BATCH
150 A = PPN !RESTORE A AND CONTINUE
CALL SCANAC !SCAN ACCT.SYS FOR HIS PPN
IF (B .NE. 0) GOTO 200 !HE'S NOT IN ACCT.SYS
D(0) = 1
D(1) = I * "1000000 + M(A + (TB*512)) !SET UP ARGS FOR UUO
A = "400005
CALL SCDEXE !DO THE UUO
IF (B .NE. 0) GOTO 300 !SCHED. UUO FAILED, TELL THE MAN
GOTO 200
300 WRITE (OUTU, 98) I
98 FORMAT (/, X, 'SCHED. UUO FAILED FOR JOB ', I4)
CALL ERRCON !TELL HIM THE ERROR
200 CONTINUE
WRITE (OUTU, 99)
99 FORMAT (//, X, 'ALL OTHER JOBS DONE.')
RETURN
END
SUBROUTINE SCANAC
IMPLICIT INTEGER (A-Z)
PARAMETER CLSWRD=19 !WORD NUMBER OF CLASS STUFF
PARAMETER AEMAX=208 !SIZE OF PROFILE
PARAMETER AEPPN=1 !WORD NUMBER OF PPN IN PROFILE
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
*
* CALL PROGET TO GET USER PROFILE OF THIS PPN
* TAKES PPN IN A, RETURNS SCD TYPE IN A
*
CALL PROGET !GO ASK ACTDAE FOR USER PROFILE
IF (B .NE. 0) GOTO 100 !GO DECODE ERROR IF NEED BE
B = D(0) !GET VERSION AND LENGTH WORD
ACTSIZ = B .AND. "777777 !SIZE OF EACH ENTRY
IF (ACTSIZ .GT. AEMAX) GOTO 998 !CLEARLY IMPOSSIBLE
IF (CLSWRD .GT. ACTSIZ) GOTO 998
B = B .AND. "777777000000 !MASK OFF BORING STUFF
IF (B .NE. "6000000) GOTO 998 !RIGHT VERSION OF ACCT.SYS?
B = 0 !CLEAR ERROR FLAG
A = (D(CLSWRD) .AND. "777000) / "1000 !EXTRACT SCHED CLASS
RETURN
*
*HERE TO DECODE ERROR RETURNED BY ACTDAE IN REPSONSE BLOCK
*
100 B = D(0) * "10000000 !GET 3 CHAR SUFFIX LEFT JUSTIFIED
IF (B .NE. 'NP') GOTO 115 !IF NO SUCH PPN FALL THRU
105 WRITE (OUTU, 110) A
110 FORMAT (X, 'USER ', O12, ' NOT IN ACTDAE.SYS')
B=1; A=0 !HE WASN'T IN ACCT.SYS
RETURN
115 WRITE (OUTU, 120) A,D !UNEXPECTED ERROR
120 FORMAT (X, 'ERROR WHILE GETTING PROFILE FOR ',O12, ':',/,10A5)
STOP
998 WRITE (OUTU, 89)
89 FORMAT (X, 'WRONG VERSION OF ACTDAE.SYS')
STOP
END
SUBROUTINE MOVSCD
IMPLICIT INTEGER (A-Z)
COMMON A, B, D, W, Z, HCL, INU, OUTU
DIMENSION D(0:512)
DIMENSION M(0:255)
*
* THIS ROUTINE MOVES A SCDMAP.SYS FILE TO THE
* SYSTEM AREA. PIP SHOULD BE ABLE TO DO THE JOB,
* BUT THIS FUNCTION IS PROVIDED FOR THE CONVENIENCE
* OF THE SYSTEM ADMINISTRATOR.
*
CALL TTYMOD !RETURN TO CONVERSATIONAL MODE
WRITE (OUTU, 93)
93 FORMAT (X, 'WHAT FILE DO YOU WISH TO MOVE TO SYS')
OPEN (UNIT=20, ACCESS='SEQIN', MODE='DUMP', DEVICE='DSK',
1 FILE='SCDMAP.SYS', DIRECTORY='1,2', DIALOG)
READ (20, END=999, ERR=998) M
CLOSE (UNIT=20)
WRITE (OUTU, 99)
99 FORMAT (X, 'FILE SUCCESSFULLY READ IN.')
OPEN (UNIT=20, ACCESS='SEQOUT', MODE='DUMP', DEVICE='SYS',
1 FILE='SCDMAP.SYS', DIALOG)
WRITE (20, ERR=997) M
CLOSE (UNIT=20)
WRITE (OUTU, 98)
98 FORMAT (X, 'FILE SUCCESSFULLY WRITTEN OUT.')
CALL NEWSCD !TELL ACTDAE TO REREAD SCDMAP.SYS
IF (B .EQ. 0) RETURN
WRITE (OUTU, 92) D
92 FORMAT(X, 'ACTDAE COULD NOT REREAD SCDMAP.SYS, ERROR: ',/,10A5)
RETURN
999 WRITE (OUTU, 96)
96 FORMAT (X, 'REACHED END OF FILE TOO SOON.')
CLOSE (UNIT=20)
RETURN
998 WRITE (OUTU, 95)
95 FORMAT (X, 'ERROR IN READING FILE.')
CLOSE (UNIT=20)
RETURN
997 WRITE (OUTU, 94)
94 FORMAT (X, 'COULD NOT WRITE FILE TO SYS:')
CLOSE (UNIT=20)
RETURN
END
INTEGER FUNCTION STRMCH(ALIST,ALISTD,SRC)
IMPLICIT INTEGER (A-Z)
DIMENSION ALIST(200), SRC(80), ALISTD(3)
*
* STRMCH IS A FUNCTION SUBPROGRAM WHICH WILL
* LOCATE AN OCCURRENCE OF A STRING (COMMAND)
* IN A TABLE OF POSSIBLE COMMAND STRINGS. A
* COMMAND IS DEFINED AS AN OCCURRENCE OF AN
* UNAMBIGUOUS SUBSTRING OF A PRESPECIFIED MINIMUM
* LENGTH WHICH MATCHES EXACTLY THE CORRESPONDING
* SUBSTRING OF A COMMAND IN THE COMMAND TABLE.
*
* THIS SUBROUTINE ACCEPTS THREE INPUT ARRAYS:
* ALIST IS A TWO DIMENSIONAL ARRAY OF POSSIBLE
* COMMANDS. THE FIRST SUBSCRIPT ITERATES ON
* ON THE CHARACTERS IN THE COMMAND (IN A1 FORMAT)
* AND THE SECOND SUBSCRIPT ITERATES ON THE
* COMMANDS.
* -ALISTD IS A DESCRIPTOR ARRAY OF LENGTH 3.
* THE FIRST ELEMENT IS THE MAX NUMBER OF CHARACTERS
* PER COMMAND.
* THE SECOND ELEMENT IS THE NUMBER OF COMMANDS.
* THE THIRD ELEMENT IS THE MINIMUM NUMBER OF
* CHARACTERS WHICH MUST MATCH TO BE CONSIDERED
* AS A MATCH ON THE ENTIRE COMMAND.
* - SRC IS A CHARACTER ARRAY (IN A1 FORMAT) WHICH
* CONTAINS THE COMMAND TO BE SEARCHED.
*
DATA BLANK/' '/,COMMA/', '/
Q1 = ALISTD(1)
Q2 = ALISTD(2)
K=0
AMB = 0
CURMCH = 0
MINMCH = ALISTD(3)
DO 30 I=1,Q2
Q3 = (I-1)*Q1
DO 10 J=1,Q1
Q3 = Q3 + 1
IF (ALIST(Q3) .NE. SRC(J)) GOTO 20
10 CONTINUE
J = Q1+1
20 J = J-1
IF (SRC(J) .NE. BLANK .AND.
1 SRC(J+1) .NE. BLANK .AND. SRC(J+1) .NE. COMMA) J=0
IF (J .LT. MINMCH) J=0
IF (J .LT. CURMCH) GOTO 30
K=I
AMB = 0
IF (J .EQ. CURMCH) AMB = 1
CURMCH = J
30 CONTINUE
IF (AMB .NE. 0) K=0
STRMCH = K
RETURN
END
Reference in New Issue View Git Blame Copy Permalink