C REV. 23
      INTEGER FUNCTION LTEXT(N)
      LTEXT=IDISK(4,1,1,N)
      RETURN
      END
C
      INTEGER FUNCTION STEXT(N)
      STEXT=IDISK(5,1,1,N)
      RETURN
      END
C
      INTEGER FUNCTION TRAVEL(M,N)
      TRAVEL=IDISK(8,3,M,N)
      RETURN
      END
C
      INTEGER FUNCTION IDISK(ILUN,IDIM,ISUB1,ISUB2)
      INTEGER BUF(64)
      DATA ILAST,NLAST/2*0/
      K=64/IDIM
      J=ISUB2-1
      NREC=1+J/K
      IF (ILAST .EQ. ILUN .AND. NLAST .EQ. NREC) GO TO 1
      ILAST=ILUN
      NLAST=NREC
      READ(ILUN,REC=NREC) BUF
   1  IT=MOD(J,K)*IDIM+ISUB1
      IDISK=BUF(IT)
      RETURN
      END
C
      INTEGER FUNCTION RTEXT(N)
      RTEXT=IDISK(10,1,1,N)
      RETURN
      END
C
      INTEGER FUNCTION VOCAB2(ID,INIT)
      INTEGER TABSIZ
      REAL ID,ATAB
      COMMON /VOCCOM/ TABSIZ
C
C      WRITE(3,100)ID,INIT
C 100  FORMAT(1X,'VOCAB(',A4,',',I3,')')
      DO 1 I=1,TABSIZ
      IK=KTAB(I)
      IF (IK .EQ. -1) GO TO 2
      IF (INIT .GE. 0 .AND. IK/1000 .NE. INIT) GO TO 1
      IF (ATAB(I) .EQ. ID) GO TO 3
   1  CONTINUE
      CALL BUG(21)
C
   2  VOCAB2=-1
      IF (INIT .LT. 0) RETURN
      WRITE(3,100) ID
 100  FORMAT(1X,'KEYWORD = ',A4)
      CALL BUG(5)
C
   3  VOCAB2=IK
      IF (INIT .GE. 0) VOCAB2=MOD(VOCAB2,1000)
      RETURN
      END
      SUBROUTINE CARRY(OBJECT,WHERE)
      INTEGER ATLOC,LINK,PLACE,FIXED,HOLDNG,OBJECT,WHERE,TEMP
      DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
      COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
C
      IF (OBJECT .GT. 100) GO TO 5
      IF (PLACE(OBJECT) .EQ. -1) RETURN
      PLACE(OBJECT)=-1
      HOLDNG=HOLDNG+1
   5  IF (ATLOC(WHERE) .NE. OBJECT) GO TO 6
      ATLOC(WHERE)=LINK(OBJECT)
      RETURN
   6  TEMP=ATLOC(WHERE)
   7  IF (LINK(TEMP) .EQ. OBJECT) GO TO 8
      TEMP=LINK(TEMP)
      GO TO 7
   8  LINK(TEMP)=LINK(OBJECT)
      RETURN
      END
C
      SUBROUTINE DROP(OBJECT,WHERE)
      INTEGER ATLOC,LINK,PLACE,FIXED,HOLDNG,OBJECT,WHERE
      DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
      COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
C
      IF (OBJECT .GT. 100) GO TO 1
      IF (PLACE(OBJECT) .EQ. -1) HOLDNG=HOLDNG-1
      PLACE(OBJECT)=WHERE
      GO TO 2
   1  FIXED(OBJECT-100)=WHERE
   2  IF (WHERE .LE. 0) RETURN
      LINK(OBJECT)=ATLOC(WHERE)
      ATLOC(WHERE)=OBJECT
      RETURN
      END
C
      INTEGER FUNCTION PUT(OBJECT,WHERE,PVAL)
      INTEGER OBJECT,WHERE,PVAL
      CALL MOVE(OBJECT,WHERE)
      PUT=-1-PVAL
      RETURN
      END
C
      SUBROUTINE MOVE(OBJECT,WHERE)
      INTEGER ATLOC,LINK,PLACE,FIXED,OBJECT,WHERE,FROM,HOLDNG
      DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
      COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED,HOLDNG
C
      IF (OBJECT .GT. 100) GO TO 1
      FROM=PLACE(OBJECT)
      GO TO 2
   1  FROM=FIXED(OBJECT-100)
   2  IF (FROM .GT. 0 .AND. FROM .LE. 300) CALL CARRY(OBJECT,FROM)
      CALL DROP(OBJECT,WHERE)
      RETURN
      END
C
      SUBROUTINE JUGGLE(OBJECT)
      INTEGER ATLOC,LINK,PLACE,FIXED,HOLDNG,OBJECT
      DIMENSION ATLOC(150),LINK(200),PLACE(100),FIXED(100)
      COMMON /PLACOM/ ATLOC,LINK,PLACE,FIXED
C
      I=PLACE(OBJECT)
      J=FIXED(OBJECT)
      CALL MOVE(OBJECT,I)
      CALL MOVE(OBJECT+100,J)
      RETURN
      END
C
      SUBROUTINE DSTROY(OBJECT)
      INTEGER OBJECT
      CALL MOVE(OBJECT,0)
      RETURN
      END
C
      INTEGER FUNCTION VOCAB(ID,INIT)
      INTEGER KTAB,TABSIZ
      REAL ID,ATAB
      DIMENSION KTAB(300),ATAB(300)
      COMMON /VOCCOM/ KTAB,ATAB,TABSIZ
C
      DO 1 I=1,TABSIZ
      IF (KTAB(I) .EQ. -1) GO TO 2
      IF (INIT .GE. 0 .AND. KTAB(I)/1000 .NE. INIT) GO TO 1
      IF (ATAB(I) .EQ. ID) GO TO 3
   1  CONTINUE
      CALL BUG(21)
C
   2  VOCAB=-1
      IF (INIT .LT. 0) RETURN
      WRITE(3,100) ID
 100  FORMAT(1X,'KEYWORD = ',A4)
      CALL BUG(5)
C
   3  VOCAB=KTAB(I)
      IF (INIT .GE. 0) VOCAB=MOD(VOCAB,1000)
      RETURN
      END
C
      SUBROUTINE A5TOA1(A,B,C,CHARS,LENG)
      LOGICAL FLG
      REAL A,B,C,D
      LOGICAL I,J,K,M
      LOGICAL CHARS(20),TEST(4),BLANK
      EQUIVALENCE (D,TEST(1))
      DATA BLANK/' '/
C
      DO 9 I=1,20
   9  CHARS(I)=BLANK
C
      D=A
      DO 1 I=1,4
   1  CHARS(I)=TEST(I)
C
      D=B
      DO 2 I=1,4
   2  CHARS(I+4)=TEST(I)
C
      D=C
      J=9
      IF (TEST(1) .GE. 65) J=10
      M=1
      K=J+3
      DO 3 I=J,K
      CHARS(I)=TEST(M)
   3  M=M+1
C
      DO 10 I=1,19
  12  IF (CHARS(I) .NE. BLANK .OR. CHARS(I+1) .NE. BLANK)GOTO 10
      FLG=.FALSE.
      J=I+1
      DO 11 K=J,20
      IF (CHARS(K) .NE. BLANK) FLG=.TRUE.
  11  CHARS(K-1)=CHARS(K)
      CHARS(20)=BLANK
      IF (FLG) GO TO 12
  10  CONTINUE
C
      DO 4 I=1,20
      LENG=21-I
      IF (CHARS(LENG) .EQ. BLANK) GO TO 4
      RETURN
   4  CONTINUE
      CALL BUG(99)
      END
        INTEGER FUNCTION RAN(RANGE)
C  SINCE THE RAN FUNCTION IN LIB40 SEEMS TO BE A REAL LOSE, WE'LL USE ONE OF
C  OUR OWN.  IT'S BEEN RUN THROUGH MANY OF THE TESTS IN KNUTH VOL. 2 AND
C  SEEMS TO BE QUITE RELIABLE.  RAN RETURNS A VALUE UNIFORMLY SELECTED
C  BETWEEN 0 AND RANGE-1.  NOTE RESEMBLANCE TO ALG USED IN WIZARD.
      INTEGER RANGE,D,R,T
        DATA R/0/
        D=1
        IF(R.NE.0)GOTO 1
      WRITE(3,3)
   3  FORMAT(1X,'Type 3 digits, please.  ')
      READ(3,4) D
   4  FORMAT(I3)
      R=3
        D=1000+D
1       DO 2 T=1,D
2       R=R * 81
        RAN=RANGE * (FLOAT(IABS(R))/32768.)
        RETURN
        END
        SUBROUTINE BUG(NUM)
C  THE FOLLOWING CONDITIONS ARE CURRENTLY CONSIDERED FATAL BUGS.  NUMBERS < 20
C  ARE DETECTED WHILE READING THE DATABASE; THE OTHERS OCCUR AT "RUN TIME".
C       0       MESSAGE LINE > 70 CHARACTERS
C       1       NULL LINE IN MESSAGE
C       2       TOO MANY WORDS OF MESSAGES
C       3       TOO MANY TRAVEL OPTIONS
C       4       TOO MANY VOCABULARY WORDS
C       5       REQUIRED VOCABULARY WORD NOT FOUND
C       6       TOO MANY RTEXT OR MTEXT MESSAGES
C       7       TOO MANY HINTS
C       8       LOCATION HAS COND BIT BEING SET TWICE
C       9       INVALID SECTION NUMBER IN DATABASE
C       20      SPECIAL TRAVEL (500>L>300) EXCEEDS GOTO LIST
C       21      RAN OFF END OF VOCABULARY TABLE
C       22      VOCABULARY TYPE (N/1000) NOT BETWEEN 0 AND 3
C       23      INTRANSITIVE ACTION VERB EXCEEDS GOTO LIST
C       24      TRANSITIVE ACTION VERB EXCEEDS GOTO LIST
C       25      CONDITIONAL TRAVEL ENTRY WITH NO ALTERNATIVE
C       26      LOCATION HAS NO TRAVEL ENTRIES
C       27      HINT NUMBER EXCEEDS GOTO LIST
C       28      INVALID MONTH RETURNED BY DATE FUNCTION
        WRITE(3,1) NUM
1       FORMAT (' FATAL ERROR, SEE SOURCE CODE FOR INTERPRETATION.'/
     1       ' PROBABLY CAUSE: ERRONEOUS INFO IN DATABASE.'/
     2       ' ERROR CODE =',I2/)
        STOP
        END
C  I/O ROUTINES (SPEAK, PSPEAK, RSPEAK, GETIN, YES, A5TOA1)
        SUBROUTINE SPEAK(N)
C  PRINT THE MESSAGE IN RECORD N OF THE RANDOM ACCESS MESSAGE FILE.
C  PRECEDE IT WITH A BLANK LINE UNLESS BLKLIN IS FALSE.
      INTEGER*2 RTEXT,ASCVAR,N,OLDLOC,LOC2(2),ASC2,ASC3,OLDASC
        LOGICAL BLKLIN
      REAL LINES(15),HNULL,HBLANK,LINES2(15,2)
        COMMON /TXTCOM/ LINES,ASCVAR
        COMMON /BLKCOM/ BLKLIN
      DATA HNULL/'>$< '/,HBLANK/'    '/,OLDASC/0/
C
      ASCVAR=N
        IF(N.EQ.0)RETURN
	ASC3=(ASCVAR-1)/2+1
	ASC2=MOD((ASCVAR-1),2)+1
        IF (OLDASC.NE.ASC3) READ(6,REC=ASC3) LOC2,LINES2
	LOC=LOC2(ASC2)
	DO 10 IJ=1,15
10	LINES(IJ)=LINES2(IJ,ASC2)
	OLDASC=ASC3
      ASCVAR=ASCVAR+1
        IF(LINES(1).EQ.HNULL)RETURN
        IF(BLKLIN) WRITE(3,2)
1       OLDLOC = LOC
        DO 3 I2=1,15
      I=16-I2
        L = I
        IF(LINES(I) .NE. HBLANK) GO TO 5
3       CONTINUE
5       WRITE(3,2) (LINES(I),I=1,L)
2       FORMAT(1X,15A4)
	ASC3=(ASCVAR-1)/2+1
	ASC2=MOD((ASCVAR-1),2)+1
        IF (OLDASC.NE.ASC3) READ(6,REC=ASC3) LOC2,LINES2
	LOC=LOC2(ASC2)
	DO 11 IJ=1,15
11	LINES(IJ)=LINES2(IJ,ASC2)
	OLDASC=ASC3
      ASCVAR=ASCVAR+1
        IF(LOC .EQ. OLDLOC) GO TO 1
      RETURN
        END
        SUBROUTINE PSPEAK(MSG,SKIP)
C  FIND THE SKIP+1ST MESSAGE FROM MSG AND PRINT IT.  MSG SHOULD BE THE INDEX OF
C  THE INVENTORY MESSAGE FOR OBJECT.  (INVEN+N+1 MESSAGE IS PROP=N MESSAGE).
       INTEGER*2 RTEXT,PTEXT,ASCVAR
      INTEGER SKIP,OLDLOC,ASC2,ASC3,OLDASC,LOC2(2)
      LOGICAL I,IS1
      REAL LINES,LINES2(15,2)
        DIMENSION LINES(15),PTEXT(100)
        COMMON /TXTCOM/ LINES,ASCVAR
        COMMON /PTXCOM/ PTEXT
	DATA OLDASC/0/
        M=PTEXT(MSG)
        IF(SKIP.LT.0)GOTO 9
      IS1=SKIP+2
      OLDLOC=-1
      DO 3 I=1,IS1
1	ASC3=(M-1)/2+1
	ASC2=MOD((M-1),2)+1
        IF (OLDASC.NE.ASC3) READ(6,REC=ASC3) LOC2,LINES2
	LOC=LOC2(ASC2)
	DO 11 IJ=1,15
11	LINES(IJ)=LINES2(IJ,ASC2)
	OLDASC=ASC3
      M=M+1
      IF (OLDLOC .EQ. LOC) GO TO 1
      OLDLOC=LOC
   3  CONTINUE
      M=M-1
9       CALL SPEAK(M)
        RETURN
        END
        SUBROUTINE RSPEAK(I)
C  PRINT THE I-TH "RANDOM" MESSAGE (SECTION 6 OF DATABASE).
       INTEGER*2 RTEXT,ASCVAR
        IF(I.NE.0)CALL SPEAK(RTEXT(I))
        RETURN
        END
        SUBROUTINE MSPEAK(I)
C  PRINT THE I-TH "MAGIC" MESSAGE (SECTION 12 OF DATABASE).
       INTEGER*2 MTEXT,ASCVAR
        DIMENSION MTEXT(35)
        COMMON /MTXCOM/ MTEXT
        IF(I.NE.0)CALL SPEAK(MTEXT(I))
        RETURN
        END
        SUBROUTINE GETIN(WORD1,WORD1X,WORD2,WORD2X)
C  GET A COMMAND FROM THE ADVENTURER.  SNARF OUT THE FIRST WORD, PAD IT WITH
C  BLANKS, AND RETURN IT IN WORD1.  CHARS 5 THRU 8 ARE RETURNED IN WORD1X, IN
C  CASE WE NEED TO PRINT OUT THE WHOLE WORD IN AN ERROR MESSAGE.  ANY NUMBER OF
C  BLANKS MAY FOLLOW THE WORD.  IF A SECOND WORD APPEARS, IT IS RETURNED IN
C  WORD2 (CHARS 5 THRU 8 IN WORD2X), ELSE WORD2 IS SET TO ZERO.
      INTEGER ST2
      REAL WORD1,WORD1X,WORD2,WORD2X,A1(2),A2(2)
      LOGICAL W1(8),W2(8),CR,BL
      INTEGER IBL(8)
        LOGICAL BLKLIN
      LOGICAL IL,LA,LZ
        LOGICAL*1 FRST(20)
        COMMON /BLKCOM/ BLKLIN
      EQUIVALENCE (A1(1),W1(1)), (A2(1),W2(1))
      EQUIVALENCE (W1(1),IBL(1)),(W2(1),IBL(5))
      EQUIVALENCE (IL,FRST(1))
      DATA LA,LZ/'A','Z'/
      DATA CR,BL/X'0D',' '/
      DO 99 IL=1,8
  99  IBL(IL)='  '
        IF(BLKLIN) WRITE(3,1)
1       FORMAT(1X)
      WRITE(3,103)
 103  FORMAT(1X,'->')
2       READ(3,3) FRST
3       FORMAT(20A1)
      DO 2000 I=1,20
      IF (FRST(I) .EQ. CR) FRST(I)=BL
      IF(LA .LE. FRST(I) .AND. FRST(I) .LE. LZ) FRST(I) =
     2  FRST(I)+BL
2000  CONTINUE
        ST2 = 1
        IX1 = 0
        IX2 = 0
        I = 0
10      I = I + 1
        IF(I .GT. 20) GO TO 2
        IF(FRST(I) .EQ. BL) GO TO 10
15      IX1 = IX1 + 1
      IF (IX1 .LE. 8) W1(IX1)=FRST(I)
        I = I + 1
        IF(I .GT. 20) GO TO 500
        IF(FRST(I) .NE. BL) GO TO 15
20      I = I + 1
        IF(I .GT. 20) GO TO 500
        IF(FRST(I) .EQ. BL) GO TO 20
        ST2 = I
25      IX2 = IX2 + 1
      IF (IX2 .LE. 8) W2(IX2)=FRST(I)
        I = I + 1
        IF(I .GT. 20) GO TO 500
        IF(FRST(I) .NE. BL) GO TO 25
 500  WORD1=A1(1)
      WORD1X=A1(2)
        WORD2 = 0.
        IF(IX2 .EQ. 0) RETURN
      WORD2=A2(1)
      WORD2X=A2(2)
        RETURN
        END
        LOGICAL FUNCTION YES(X,Y,Z)
C  CALL YESX (BELOW) WITH MESSAGES FROM SECTION 6.
      INTEGER X,Y,Z
        EXTERNAL RSPEAK
        LOGICAL YESX
        YES=YESX(X,Y,Z,RSPEAK)
        RETURN
        END
        LOGICAL FUNCTION YESM(X,Y,Z)
C  CALL YESX (BELOW) WITH MESSAGES FROM SECTION 12.
      INTEGER X,Y,Z
        EXTERNAL MSPEAK
        LOGICAL YESX
        YESM=YESX(X,Y,Z,MSPEAK)
        RETURN
        END
        LOGICAL FUNCTION YESX(X,Y,Z,SPK)
C  PRINT MESSAGE X, WAIT FOR YES/NO ANSWER.  IF YES, PRINT Y AND LEAVE YEA
C  TRUE; IF NO, PRINT Z AND LEAVE YEA FALSE.  SPK IS EITHER RSPEAK OR MSPEAK.
      INTEGER X,Y,Z
      REAL REPLY,JUNK1,JUNK2,JUNK3,HY1,HY2,HN1,HN2
      DATA HY1,HY2,HN1,HN2/'y   ','yes ','n   ','no  '/
1       IF(X.NE.0)CALL SPK(X)
        CALL GETIN(REPLY,JUNK1,JUNK2,JUNK3)
        IF(REPLY.EQ.HY1.OR.REPLY.EQ.HY2)GOTO 10
        IF(REPLY.EQ.HN1.OR.REPLY.EQ.HN2)GOTO 20
      WRITE(3,9)
9       FORMAT(/' Please answer the question.')
        GOTO 1
10      YESX=.TRUE.
        IF(Y.NE.0)CALL SPK(Y)
        RETURN
20      YESX=.FALSE.
        IF(Z.NE.0)CALL SPK(Z)
        RETURN
        END
      REAL FUNCTION ATAB(I)
      REAL BUF(32)
      DATA N/0/
      J=1+(I-1)/32
      K=MOD(I,32)
      IF (K .EQ. 0) K=32
      IF (J .EQ. N) GO TO 1
      N=J
      READ(7,REC=N)BUF
   1  ATAB=BUF(K)
      RETURN
      END
C
      INTEGER FUNCTION KTAB(N)
      KTAB=IDISK(9,1,1,N)
C      WRITE(3,100)N,KTAB
C 100  FORMAT(1X,'KTAB(',I3,')=',I4)
      RETURN
      END