	PROGRAM DAVESCAVE
C    DUNGEONS AND DRAGONS WRITTEN BY DAVE PARKER
C	DISTRIBUTED BY:
C		MITRE CORP.
C		DEPT W-45
C		WESTGATE PARK
C		MC LEAN, VA. 22102
C
C	VERSION 1.0,  DATED SEPT 1980
C
	INTEGER*2 IDATA(2500),ITEXT(500),IROOM(250),ITEM(9)
	INTEGER*4 ICHAR(3),INIT(3)
	LOGICAL*1 LDFLAG
	BYTE BRESP,BNAME(18),CNAME(18),DNAME(18)
	INTEGER*4 TNAME(10)
	COMMON /DANDD1/IDATA,IPT,IWAS,ITEXT
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM,
     X	 IUSED,MXITMS,LDFLAG
	COMMON /DANDD3/BNAME,CNAME,DNAME,TNAME
C
C **********************************************************************
C **** THE FOLLOWING DATA STATEMENTS MAY HAVE TO BE MODIFIED ACCORDING
C	TO THE INSTALLATION.
C	BNAME, CNAME, AND DNAME WILL BE CREATED IN THE USERS UIC WITH HIS
C	INITIALS AS AN EXTENSION.
C	TNAME (TEXTFILE.DAD) MUST BE IN THE USERS DIRECTORY OR ASSIGNED TO
C	A COPY IN SOME REFERENCE DIRECTORY
	DATA BNAME/'R','O','O','M','F','I','L','E',
     X	 '.','D','A','D',6*0/
	DATA CNAME/'C','H','A','R','F','I','L','E',
     X	 '.','D','A','D',6*0/
	DATA DNAME/'D','A','T','A','F','I','L','E',
     X	 '.','D','A','D',6*0/
	DATA TNAME/'TEXT','FILE','.DAD',7*0/
C ***********************************************************************
C
C  INITIALIZE SEEDS OF RANDOM NUMBER GENERATOR
	I1=SECNDS(0.)/3.7
	I2=SECNDS(0.)/7.3
 100	CALL START
	CALL SINSTR
	CALL SEND
	WRITE (5,901)
 901	FORMAT (1X,'WOULD YOU LIKE TO RUN ANOTHER EXPEDITION?')
	READ (5,902) BRESP
 902	FORMAT (1A1)
	IF (BRESP .NE. 78) GO TO 100
	STOP
	END
	SUBROUTINE START
	INTEGER*2 IDATA(2500),ITEXT(500),IROOM(250),ITEM(9)
	INTEGER*4 ICHAR(3),INIT(3)
	BYTE BNAME(18),CNAME(18),DNAME(18),BRESP,BMOD
	INTEGER*4	TNAME(10)
	LOGICAL*1 LDFLAG
	COMMON /DANDD1/IDATA,IPT,IWAS,ITEXT
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM
     X	 ,IUSED,MXITMS,LDFLAG
	COMMON /DANDD3/BNAME,CNAME,DNAME,TNAME
	DATA BNAME/'S','I','A','0',':','R','O','O','M','F','I','L',
     X	 'E','.','D','A','D',0/
	DATA CNAME/'S','I','A','0',':','C','H','A','R','F','I','L',
     X	 'E','.','D','A','D',0/
	DATA DNAME/'S','I','A','0',':','D','A','T','A','F','I','L',
     X	 'E','.','D','A','D',0/
	DATA BMOD/' '/
C
	WRITE (5,901)
 901	FORMAT (' WELCOME TO DAVE''S DUNGEON'/
     +  ' ENTER YOUR THREE INITIALS')
	READ (5,902) (BNAME(I),I=15,17)
 902	FORMAT (3A1)
	DO 3 I=14,17
	 CNAME(I)=BNAME(I)
 3	 DNAME(I)=BNAME(I)
	WRITE(5,903)
903	FORMAT(' DO YOU WANT TO CONTINUE AN OLD GAME?  ',$)
	READ(5,902)BRESP
	IF (BRESP.EQ.'Y'.OR.BRESP.EQ.'y')  GOTO 5
	BMOD='A'		!TO RESET ALL (CREATE NEW)
4	CALL RESET (BNAME(15),BMOD)
	GOTO 6
C
5	CONTINUE
	BMOD=' '
	WRITE(5,908)' DO YOU WANT TO MODIFY YOUR LAST GAME?  '
908	FORMAT(X,A,$)
	READ (5,902) BRESP
	IF (BRESP.EQ.'Y'.OR. BREST.EQ.'y') CALL RESET(BNAME(15),BMOD)
	BMOD='A'		!TO RESET ALL IF OPEN FAILS
6	OPEN (UNIT=1,NAME=CNAME,TYPE='OLD',FORM='UNFORMATTED',ERR=920)
	READ (1,ERR=7) (ICHAR(I),I=1,3)
	GOTO 8
7	TYPE *,(' NOTHING IN CNAME - CHARFILE.INT - ATTEMPTING RESET')
	INIT(1)=1
	INIT(2)=0
	INIT(3)=0
	DO 75 I=1,3
75	WRITE(1) INIT(I)
	GOTO 6
 8	CLOSE (UNIT=1)
 	OPEN (UNIT=3,NAME=BNAME,TYPE='OLD',FORM='UNFORMATTED',ERR=920)
	READ (3,END=10) (IROOM(I),I=1,250)
 10	CLOSE (UNIT=3)
	OPEN (UNIT=2,NAME=DNAME,TYPE='OLD',FORM='UNFORMATTED',ERR=920)
	WRITE (5,906)
 906	FORMAT (1X,'WOULD YOU LIKE INSTRUCTIONS?  '$)
C  CHANGE THIS OPEN TO CORRESPOND WITH MASTER TEXTFILE.DAD LOCATION.
	OPEN (UNIT=1,NAME=TNAME,TYPE='OLD',FORM=
     X	 'UNFORMATTED')
	READ (1) (ITEXT(I),I=1,500)
	DO 20 I=1,2001,500
	 IEND=I+499
 20	 READ (2) (IDATA(J),J=I,IEND)
 	CLOSE (UNIT=1)
	CLOSE (UNIT=2)
	READ (5,904) BRESP
 904	FORMAT (A1)
	IF (BRESP .NE. 78) CALL SSLIST
	CALL SCLIST (ICHAR)
	CALL SMLIST (ICHAR(3))
	WRITE (5,907)
 907	FORMAT (1X,'DEEP IN THE MISTY MOUNTAINS YOU COME UPON A'/
     X	 ' GATE IN THE SIDE OF A CLIFF. YOU SPEAK THE'/
     X   ' WORD ''ENTER'' AND YOU ARE INSIDE.')
	NHITS=0
	NSPELL=ICHAR(1)+1
	NITEM=0
	IUSED=0
	IPT=251
	IRUST=0
	MXITMS=6
	IF (IAND(ICHAR(3),64) .NE. 0) MXITMS=9
	I1=SECNDS(0.)/3
	I2=SECNDS(0.)/7
	LDFLAG=.FALSE.
	CALL SDESCR
	RETURN
920	WRITE(5,925) 
925	FORMAT(X,'YOU HAVE NO DATA FROM AN OLD GAME,'/
     +   X,'I WILL GENERATE A NEW ONE.')
	GOTO 4
	END
	SUBROUTINE SCLIST(ICHAR)
	INTEGER*4 ICHAR(3),ISHORT
	IF (ICHAR(2) .LT. 2000) ICHAR(1)=1
	IF (ICHAR(2).GE.2000) ICHAR(1)=ALOG(ICHAR(2)/1000.)/.693147+1
	ISHORT=1000*2**ICHAR(1)-ICHAR(2)
	WRITE (5,901) ICHAR(1),ICHAR(2),ISHORT
 901	FORMAT (1X,'YOU ARE A LEVEL ',I2,' ADVENTURER WITH ',I8,
     X	 ' EXPERIENCE POINTS.'/' TO REACH THE NEXT LEVEL YOU NEED ',
     X   I8,' MORE POINTS.')
	RETURN
	END
	SUBROUTINE SSLIST
	WRITE (5,901)
	WRITE (5,902)
 901	FORMAT (
     X' DEEP IN THE MOUNTAINS IS A MAGIC ELVEN GATE LEADING TO AN'/
     X' ANCIENT DUNGEON WHERE FOUL CREATURES ARE RUMORED TO GUARD'/
     X' FABULOUS TREASURES. I WILL BE YOUR EYES, EARS AND HANDS IN'/
     X' THE DUNGEON. I WILL DESCRIBE YOUR SURROUNDINGS. YOU TELL ME'/
     X' WHAT YOU WANT TO DO BY ENTERING TWO LETTER COMMANDS AND I'/
     X' WILL TELL YOU WHAT HAPPENS.'/
     X' YOU MAY DAMAGE A MONSTER WITH YOUR SWORD OR WITH FIREBALLS.'/
     X' HE WILL ATTACK YOU IF HE CAN. IF YOU TAKE TOO MUCH DAMAGE,'/
     X' YOU WILL DIE. IF YOU KILL HIM YOU ARE FREE TO TAKE ANY TREA-'/
     X' SURE HE MAY HAVE. MAGIC ITEMS HELP YOU DO THINGS ON LATER EX-')
 902	FORMAT (
     X' PEDITIONS. EXIT WITH THEM AND ON YOUR NEXT EXPEDITION YOU''LL'/
     X' BE ABLE TO USE THEM. YOU GET EXPERIENCE FOR TREASURE THAT YOU'/
     X' TAKE OUT AND FOR MONSTERS YOU KILL. GET ENOUGH EXPERIENCE AND'/
     X' YOU GO UP A LEVEL, MAKING YOU A BETTER FIGHTER AND INCREASING'/
     X' YOUR ABILITY TO SURVIVE. UPON EXITING THE DUNGEON YOUR CHARAC-'/
     X' TER WILL BE SAVED FOR FURTHER PLAY ANYTIME.'/
     X' THE DEEPER DOWN YOU GO THE MORE DANGEROUS IT IS BUT THE BETTER'/
     X' THE TREASURE. I WOULD RECOMMEND MAKING A MAP AS YOU GO.'/
     X' GOOD LUCK'/' '/' (HIT RETURN)')
	READ (5,905) BRESP
 905	FORMAT (A1)
	WRITE (5,906)
 906	FORMAT (1X,' '/' THESE ARE THE INSTRUCTIONS I UNDERSTAND WHILE Y
     XOU ARE TRAVELLING:'/' ')
	CALL STLIST
	WRITE (5,907)
 907	FORMAT (1X,' '/' (HIT RETURN)')
	READ (5,905) BRESP
	WRITE (5,903)
 903	FORMAT (1X,' '/' THESE ARE THE INSTRUCTIONS I UNDERSTAND WHILE Y
     XOU ARE IN BATTLE'/' ')
	CALL SBLIST
	WRITE (5,904)
 904	FORMAT (' ')
	RETURN
	END
	SUBROUTINE STLIST
	WRITE (5,901)
	WRITE (5,902)
	WRITE (5,903)
	WRITE (5,904)
	WRITE (5,905)
	WRITE (5,906)
	WRITE (5,907)
	WRITE (5,908)
	WRITE (5,909)
 901	FORMAT (1X,'EX  EXIT FROM GATE')
 902	FORMAT (1X,'HW  HOW AM I DOING?')
 903	FORMAT (1X,'LI  DISPLAY THIS LIST')
 904	FORMAT (1X,'M-  MOVE N,S,E OR W')
 905	FORMAT (1X,'QT  QUIT EXPEDITION')
 906	FORMAT (1X,'SC  THROW SPELL - CURE')
 907	FORMAT (1X,'TK  TAKE ITEM')
 908	FORMAT (1X,'UM  USE MAGIC ITEM')
 909	FORMAT (1X,'WH  WHERE AM I?')
	RETURN
	END
	SUBROUTINE SINSTR
	IMPLICIT BYTE(B)
	INTEGER*2 IDATA(2500),ITEXT(500),IROOM(250),ITEM(9)
	DIMENSION BRESP(4)
	EQUIVALENCE (BRESP(1),BRESP1),(BRESP(2),BRESP2)
	INTEGER*4 ICHAR(3)
	LOGICAL*1 LDFLAG
	COMMON /DANDD1/IDATA,IPT,IWAS,ITEXT
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM
     X	 ,IUSED,MXITMS,LDFLAG
 100	IF (RAN(I1,I2) .GT. .025) GO TO 105
	IF ((IAND(ICHAR(3),128).NE.0).AND.(RAN(I1,I2).GT..5)) GOTO 105
	IDLEV=IPT/500+1
 101	CALL SRANDE(I1,I2,Y,IDLEV*6.-3.,1.)
	IF (Y .GE. 30.) GO TO 101
	IMONST=Y+1
	IBEG=IMONST*4+55
	IEND=IBEG+3
 102	WRITE (5,920) (ITEXT(I),I=IBEG,IEND)
 920	FORMAT (1X,'FROM OUT OF THE SHADOWS LEAPS A',4A2)
	CALL SBATTL(IMONST)
	IF (.NOT.(LDFLAG)) GO TO 103
	CALL SRSTOR(IMONST*256,IDLEV)
	RETURN
 103	IF (IMONST .EQ. 0) GO TO 105
	IPT=IWAS
	CALL SDESCR
	GO TO 102
 105	WRITE (5,901)
 901	FORMAT (1X,'WHAT DO YOU DO?')
	READ (5,902) BRESP	!READS 1 TO 4 CHARS, PADDING WITH BLANKS
 902	FORMAT (4A1)
	IF ((BRESP1.LT.65).OR.(BRESP1.GT.91)) GO TO 700
	GOTO (700,700,700,700,110,700,700,400,700,700,700,150,
     X	 200,700,700,700,300,700,500,600,650,700,160,700,700,
     X	 700) BRESP1-64
 110	IF (IPT .EQ. 251) RETURN
 	WRITE (5,903)
 903	FORMAT (1X,'YOU MAY EXIT ONLY FROM GATE')
	GO TO 100
 150	CALL STLIST
	GO TO 100
 160	CALL SDESCR
	GO TO 100
 200	IF ((BRESP2.LT.65).OR.(BRESP2.GT.91)) GOTO 700
	IDIREC=1
	GOTO (700,700,700,700,230,700,700,700,700,700,700,700,
     X	 700,250,700,700,700,700,240,700,700,700,220,700,700,
     X	 700) BRESP2-64
 220	IDIREC=IDIREC+1
 230	IDIREC=IDIREC+1
 240	IDIREC=IDIREC+1
 250	CALL SMOVE(IDIREC)
 260	CALL SDESCR
	IF (LDFLAG) RETURN
	GO TO 100
 300	WRITE (5,910)
 910	FORMAT (1X,'IN TOTAL DISGUST WITH THIS GAME, YOU THROW YOURSELF
     X ONTO YOUR SWORD')
	CALL SDEAD
	RETURN
 400	MHITSP=ICHAR(1)*8
	WRITE (5,911) NHITS,MHITSP
 911	FORMAT (1X,'YOU HAVE TAKEN ',I2,' HITS OUT OF ',I2,' MAXIMUM')
	WRITE (5,912) NITEM,NSPELL
 912	FORMAT (1X,'YOU HAVE COLLECTED ',I2,' ITEMS AND HAVE ',I2,
     X	 ' SPELL(S) LEFT')
	GO TO 100
 500	IF (NSPELL .GT. 0) GO TO 510
	WRITE (5,913)
 913	FORMAT (1X,'SORRY, BUT YOU SEEM TO BE OUT OF SPELLS')
	GO TO 100
 510	NSPELL=NSPELL-1
	NCURE=NHITS*RAN(I1,I2)+1
	WRITE (5,914) NCURE
 914	FORMAT (1X,'YOU HAVE CURED ',I2,' HITS')
	NHITS=NHITS-NCURE
	GO TO 100
 600	IF (MOD(IPT,500) .LT. 250) GO TO 610
	WRITE (5,904)
 904	FORMAT (1X,'DO YOU THINK SOMEONE WOULD LEAVE TREASURE LYING AROU
     XND IN THE HALLWAY?')
	GO TO 100
 610	IRMPT=(MOD(IPT,500)+4)/5+50*(IPT/500)
 	IMGTRS=IROOM(IRMPT)
	IF (IMGTRS .GT. 0) GO TO 620
	WRITE (5,905)
 905	FORMAT (1X,'I SEE NO TREASURE HERE')
	GO TO 100
 620	IF (NITEM .LT. MXITMS) GO TO 630
	WRITE (5,906)
 906	FORMAT (1X,'UNFORTUNATELY YOU CAN''T CARRY ANY MORE')
	GO TO 100
 630	WRITE (5,907)
 907	FORMAT (1X,'OK')
 	NITEM=NITEM+1
	ITEM(NITEM)=IMGTRS
	IROOM(IRMPT)=0
	GO TO 100
C
650	CONTINUE	!MAGIC 
	IF(ICHAR(3).GT.0 .AND. BRESP(3).GT.64) GOTO 660
 	CALL SMLIST(ICHAR(3))
	IF (ICHAR(3) .EQ. 0) GO TO 100
660	IRETRN=0
	CALL SMAGIT(IRETRN,BRESP(3),BRESP(4))
	IF (IRETRN .NE. 4) GO TO 100
	IPT=IWAS
	GO TO 260
 700	WRITE (5,908)
 908	FORMAT (1X,'UNRECOGNIZED RESPONSE.TYPE LI FOR LIST
     X	 OF RECOGNIZED RESPONSES')
	GO TO 100
	END
	SUBROUTINE SMLIST(IMAGIC)
	INTEGER*2 ITEXT(500),IDATA(2500)
	INTEGER*4 IMAGIC
	COMMON /DANDD1/IDATA,IPT,IWAS,ITEXT
	IF (IMAGIC .NE. 0) GO TO 100
	WRITE (5,901)
 901	FORMAT (1X,'YOU DON''T HAVE ANY MAGIC ITEMS')
	RETURN
 100	WRITE (5,902)
 902	FORMAT (1X,'YOU HAVE THE FOLLOWING MAGIC ITEMS')
	DO 200 IBIT=0,4,2
	 IPLUS=IAND(IMAGIC,3*2**IBIT)/2**IBIT
	 IF (IPLUS .EQ. 0) GO TO 200
	 ITYPE=IBIT/2+1
	 IBEG=ITYPE*3+296
	 IEND=IBEG+2
	 WRITE (5,903) IPLUS,(ITEXT(I),I=IBEG,IEND)
 903	 FORMAT (1X,'+',I1,' MAGIC ',3A2)
 200	 CONTINUE
	DO 300 IBIT=6,14
	 IF (IAND(IMAGIC,2**IBIT) .EQ. 0) GO TO 300
	 IBEG=(IBIT-2)*3+296
	 IEND=IBEG+2
	 WRITE (5,904) (ITEXT(I),I=IBEG,IEND)
 904	 FORMAT (1X,'MAGIC ',3A2)
 300	 CONTINUE
	RETURN
	END
	SUBROUTINE SDESCR
	DIMENSION IN(2),ID(2),IDIR(3,4,3)
	INTEGER*2 IDATA(2500),ITEXT(500),IROOM(250),ITEM(9)
	INTEGER*4 ICHAR(3)
	LOGICAL*1 LDFLAG
	COMMON /DANDD1/IDATA,IPT,IWAS,ITEXT
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM
     X	 ,IUSED,MXITMS,LDFLAG
	EQUIVALENCE (IN1,IN(1)),(IN2,IN(2))
 100	ILOC=IAND(IDATA(IPT),3840)/256
	IBEG=ILOC*5+14
	IEND=IBEG+4
	WRITE (5,901) (ITEXT(I),I=IBEG,IEND)
 901	FORMAT (1X,'YOU ARE AT A',5A2)
	ID(1)=IAND(IDATA(IPT),240)/16
	ID(2)=IAND(IDATA(IPT),15)
	IN(1)=0
	IN(2)=0
	DO 130 IBIT=0,3
	 IMASK=2**IBIT
	 DO 120 NUM=1,2
	  IF (IAND(ID(NUM),IMASK).EQ.0) GOTO 120
	  IBEG=IBIT*3+1
	  IEND=IBEG+2
	  IN(NUM)=IN(NUM)+1
	  DO 110 ISECT=IBEG,IEND
 110	   IDIR(NUM,IN(NUM),ISECT-IBEG+1)=ITEXT(ISECT)
 120	 CONTINUE
 130	CONTINUE
	IF (ILOC-7) 140,150,160
 140	WRITE (5,902) ((IDIR(1,I,J),J=1,3),I=1,IN1)
 902	FORMAT (1X,'CORRIDORS RUN',12A2)
	GOTO (800,800,800,800,150,160) ILOC
 150	WRITE (5,903) ((IDIR(2,I,J),J=1,3),I=1,IN2)
 903	FORMAT (1X,'DOOR(S) TO THE',12A2)
	IF (ILOC .NE. 7) RETURN
	IRMPT=(MOD(IPT,500)+4)/5+50*(IPT/500)
	IMONST=IAND(IROOM(IRMPT),16128)/256
	IMAGIC=0
	ITREAS=0
	IMGTRS=IAND(IROOM(IRMPT),255)
	IF (IMGTRS .LE. 200) ITREAS=IMGTRS
	IF (IMGTRS .GT. 200) IMAGIC=IMGTRS-200
	IF (IMONST .EQ. 0) GO TO 152
	IBEG=IMONST*4+55
	IEND=IBEG+3
	WRITE (5,904) (ITEXT(I),I=IBEG,IEND)
 904	FORMAT (1X,'THERE IS A',4A2,' IN THE ROOM')
	CALL SBATTL(IMONST)
	IF (LDFLAG) RETURN
	IF (IMONST .EQ. 0) IROOM(IRMPT)=IAND(IROOM(IRMPT),255)
	IF (IMONST .EQ. 0) GO TO 152
	IPT=IWAS
	GO TO 100
 152	IF (IMAGIC .EQ. 0) GO TO 155
	IMAGMD=IMAGIC-3
	IF (IMAGMD .LE. 3) IMAGMD=(IMAGMD+4)/2
	IBEG=IMAGMD*3+296
	IEND=IBEG+2
	WRITE (5,910) (ITEXT(I),I=IBEG,IEND)
 910	FORMAT (1X,'IN THE CORNER IS A SHIMMERING MAGIC ',3A2)
	RETURN
 155	IF (ITREAS .EQ. 0) RETURN
	IBEG=ITREAS*8+171
	IEND=IBEG+7
	WRITE (5,905) (ITEXT(I),I=IBEG,IEND)
 905	FORMAT(1X,'LYING ON THE FLOOR IS A',8A2)
	RETURN
 160	IUBIT=IAND(IDATA(IPT),4096)/4096
	IBEG=IUBIT*3+13
	IEND=IBEG+2
	DO 165 ISECT=IBEG,IEND
 165	IDIR(3,1,ISECT-IBEG+1)=ITEXT(ISECT)
    	WRITE (5,906) (IDIR(3,1,J),J=1,3),(IDIR(2,1,J),J=1,3)
 906	FORMAT (1X,'STAIRS LEAD ',3A2,' TO THE',3A2)
	RETURN
 800	CONTINUE
	RETURN
	END
	SUBROUTINE SMOVE(IDIREC)
	INTEGER*2 IDATA(2500),ITEXT(500)
	COMMON /DANDD1/IDATA,IPT,IWAS,ITEXT
	IF (IDATA(IPT+IDIREC) .EQ. 0) GO TO 100
	IWAS=IPT
	IPT=IDATA(IPT+IDIREC)*5-4
	RETURN
 100	WRITE (5,901)
 901	FORMAT (1X,'YOU RAN INTO A WALL')
	RETURN
	END
	SUBROUTINE SMAGIT(IRETRN,BRESP1,BRESP2)
	INTEGER*2 IDATA(2500),ITEXT(500),IROOM(250),ITEM(9)
	INTEGER*4 ICHAR(3)
	BYTE BRESP1,BRESP2
	COMMON /DANDD1/IDATA,IPT,IWAS,ITEXT
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM,
     X	 IUSED,MXITMS,LDFLAG
	IF(BRESP1.GT.64) GOTO 60
 50	WRITE (5,901)
 901	FORMAT (1X,'INDICATE WHICH ITEM YOU WANT TO USE BY ENTERING
     X	 THE FIRST AND LAST'/' LETTERS OF ITS NAME')
	READ (5,902) BRESP1,BRESP2
 902	FORMAT (2A1)
60	CONTINUE
	GO TO (100,200,300,800,800,800,800,800,800,800,800,400,800,
     X	 800,800,800,800,700,700,800,800,800,600,800,800) BRESP1-64
 100	IF (BRESP2 .EQ. 82) GO TO 700
	IF (IAND(ICHAR(3),512) .EQ. 0) GO TO 830
	IF (IRETRN .EQ. 1) GO TO 860
	WRITE (5,903)
 903	FORMAT (1X,'YOU GRASP THE AMULET AND SAY ''HOME JAMES''')
	IF (IAND(IUSED,1) .NE. 0) GO TO 860
	IF (RAN(I1,I2) .GT. .025) GO TO 110
	WRITE (5,904)
 904	FORMAT (1X,'THE AMULET SPUTTERS, COUGHS AND DIES.'/
     X	  'IT TURNS TO A LITTLE PILE OF DUST')
	ICHAR(3)=IEOR(ICHAR(3),512)
	RETURN
 110	IPT=251
	IUSED=IUSED+1
	CALL SDESCR
	RETURN
 200	IF ((BRESP2.EQ.71).OR.(BRESP2.EQ.83)) GO TO 700
	IF (BRESP2 .EQ. 76) GO TO 250
	IF (IAND(ICHAR(3),4096) .EQ. 0) GO TO 830
	IF (IAND(IUSED,2) .NE. 0) GO TO 860
	IF (RAN(I1,I2) .GT. .025) GO TO 210
	WRITE (5,905)
 905	FORMAT (1X,'THE BOTTLE SLIPS FROM YOUR HANDS AND BREAKS INTO A M
     XILLION TEENY WEENY PIECES.')
	ICHAR(3)=IEOR(ICHAR(3),4096)
	RETURN
 210	WRITE (5,906)
 906	FORMAT (1X,'YOU OPEN YOUR BOTTLE AND DRINK THE GOLDEN LIQUOR INS
     XIDE'/' YOU FEEL COMPLETELY HEALED')
	NHITS=0
	IUSED=IUSED+2
	RETURN
 250	IF (IAND(ICHAR(3),2048) .EQ. 0) GO TO 830
	IF ((IAND(IUSED,224)/32.EQ.7).OR.(IRETRN.EQ.1)) GOTO 860
	IUSED=IUSED+32
	IF (RAN(I1,I2) .GT. .004) GO TO 255
	WRITE (5,907)
 907	FORMAT (1X,'THE CRYSTAL BALL FALLS FROM YOUR GRASP AND SHATTERS 
     XINTO A ZILLION ITSY BITSY BITS')
	ICHAR(3)=IEOR(ICHAR(3),2048)
	RETURN
 255	WRITE (5,908)
 908	FORMAT (1X,'THE CRYSTAL BALL BEGINS TO GLOW'/' WHICH WAY DO YOU 
     XWISH TO LOOK?')
	IDIREC=1
	READ (5,902) BRESP1,BRESP2
	GOTO (255,255,255,255,270,255,255,255,255,255,255,255,255,290,
     X255,255,255,255,280,255,255,255,260,255,255,255) BRESP1-64
 260	IDIREC=IDIREC+1
 270	IDIREC=IDIREC+1
 280	IDIREC=IDIREC+1
 290	IRMNUM=IDATA(IPT+IDIREC)
 	IF (IRMNUM .NE. 0) GO TO 292
	WRITE (5,909)
 909	FORMAT (1X,'YOU SEE A WALL')
	RETURN
 292	ISEEPT=IRMNUM*5-4
 	ISEELOC=IAND(IDATA(ISEEPT),3840)/256
	IBEG=ISEELOC*5+14
	IEND=IBEG+4
	WRITE (5,910) (ITEXT(I),I=IBEG,IEND)
 910	FORMAT (1X,'YOU SEE A',5A2)
	IF (ISEELOC .NE. 7) RETURN
	IRMPT=MOD(IRMNUM,100)+50*(IRMNUM/100)
	ISEEMN=IAND(IROOM(IRMPT),16128)/256
	ISEEMG=0
	ISEETS=0
	ISEE=IAND(IROOM(IRMPT),255)
	IF (ISEE .LE. 200) ISEETS=ISEE
	IF (ISEE .GT. 200) ISEEMG=ISEE-200
	IF (ISEEMN .EQ. 0) GO TO 293
	IBEG=ISEEMN*4+55
	IEND=IBEG+3
	WRITE (5,911) (ITEXT(I),I=IBEG,IEND)
 911	FORMAT (1X,'THERE IS A',4A2,' IN THE ROOM')
 293	IF (ISEETS .EQ. 0) GO TO 294
	IBEG=ISEETS*8+171
	IEND=IBEG+7
	WRITE (5,912) (ITEXT(I),I=IBEG,IEND)
 912	FORMAT (1X,'YOU SEE A',8A2,' ON THE FLOOR')
	RETURN
 294	IF (ISEEMG .EQ. 0) RETURN
	IMAGMD=ISEEMG-3
	IF (IMAGMD .LE. 3) IMAGMD=(IMAGMD+4)/12
	IBEG=IMAGMD*3+296
	IEND=IBEG+2
	WRITE (5,913) (ITEXT(I),I=IBEG,IEND)
 913	FORMAT (1X,'YOU SEE A MAGIC ',3A2,' IN THE CORNER')
	RETURN
 300	IF (IAND(ICHAR(3),16384).EQ.0) GOTO 830
	IF (RAN(I1,I2) .GT. .025) GO TO 310
	WRITE (5,930)
 930	FORMAT (1X,'A HUGE DEMON APPEARS IN THE ROOM'/
     X	 ' ''I''VE BEEN LOOKING ALL OVER FOR THIS'' HE SAYS'
     X	 /' HE TAKES HIS CROWN FROM YOU AND DISAPPEARS')
	ICHAR(3)=IEOR(ICHAR(3),16384)
	RETURN
 310	WRITE (5,931)
 931	FORMAT (1X,'ENTER A NUMBER BETWEEN 000 AND 500 TO'/
     X	 ' TELEPORT TO A NEW SPOT IN THE DUNGEON')
	READ (5,932) INUMB
 932	FORMAT (I3)
	IF (MOD(INUMB,100) .EQ. 0) INUMB=INUMB+1
	IF (INUMB .GT. 499) INUMB=(IPT+4)/5
	IF (INUMB .LT. 1) INUMB=51
	IWAS=INUMB*5-4
	IRETRN=4
	RETURN
 400	IF (IAND(ICHAR(3),8192) .EQ. 0) GO TO 830
	IF (IRETRN .EQ. 0) GO TO 860
	WRITE (5,914)
 914	FORMAT (1X,'YOU PULL OUT THE LAMP AND RUB IT')
	IF (IAND(IUSED,4) .NE. 0) GO TO 860
	WRITE (5,915)
 915	FORMAT (1X,'A CLOUD OF BLUE SMOKE FILLS THE ROOM AND MATERIALIZE
     XS INTO A HAREM GIRL')
	IF (RAN(I1,I2) .GT. .025) GO TO 410
	WRITE (5,916)
 916	FORMAT (1X,'SHE INFORMS YOU THAT HER 101 DAYS OF SERVITUDE ARE U
     XP,'/' TAKES HER LAMP, AND VANISHES')
	ICHAR(3)=IEOR(ICHAR(3),8192)
	RETURN
 410	WRITE (5,917)
 917	FORMAT (1X,        'SHE CROSSES HER ARMS, BLINKS, AND THE MONSTE
     XR DISAPPEARS IN A BURST OF FLAME'/' YOUR JEANNIE VANISHES')
	IUSED=IUSED+4
	IRETRN=2
	RETURN
 600	IF (IAND(ICHAR(3),1024) .EQ. 0) GO TO 830
	IF (IRETRN .EQ. 0) GO TO 860
	WRITE (5,918)
 918	FORMAT (1X,'YOU POINT THE WAND AT THE MONSTER')
	IF (IAND(IUSED,24)/8 .EQ. 3) GO TO 860
	IF (RAN(I1,I2) .GT. .008) GO TO 610
	WRITE (5,919)
 919	FORMAT (1X,'A LITTLE RED LIGHT COMES ON, ''BATTERIES EXHAUSTED''
     X IT SAYS.'/' YOU ARE NOW HOLDING A WORTHLESS STICK')
	ICHAR(3)=IEOR(ICHAR(3),1024)
	RETURN
 610	WRITE (5,920)
 920	FORMAT (1X,'A BEAM OF RED LIGHT FLIES TOWARD THE MONSTER')
	IRETRN=3
	IUSED=IUSED+8
	RETURN
 700	WRITE (5,921)
 921	FORMAT (1X,'THIS ITEM DOES NOT NEED TO BE CALLED UPON TO WORK'
     X	 /' RATHER, IT IS IN CONSTANT USE AS LONG AS YOU HAVE IT')
	RETURN
 800	WRITE (5,922)
 922	FORMAT (1X,'I KNOW OF NO SUCH ITEM')
	GO TO 50
 830	WRITE (5,923)
 923	FORMAT (1X,'THAT''S A NICE ITEM, TOO BAD YOU DON''T HAVE ONE')
	RETURN
 860	WRITE (5,924)
 924	FORMAT (1X,'NOTHING HAPPENS')
	RETURN
	END
	SUBROUTINE SBATTL(IMONST)
	BYTE BRESP1,BRESP2,BRESP(4)
	EQUIVALENCE (BRESP(1),BRESP1),(BRESP(2),BRESP2)
	INTEGER*2 IREQ(180),IROOM(250),ITEM(9)
	INTEGER*4 ICHAR(3)
	LOGICAL*1 LDFLAG
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM
     X	 ,LDFLAG
	DATA IREQ/80,-2,15,35,-2,0,75,-2,10,30,-2,0,50,-2,25,25,-2,0,60,
     X1,25,25,1,0,30,-2,5,70,-4,0,55,1,20,45,1,0,45,1,15,35,1,0,50,2,30,
     X35,1,0,20,1,15,15,-2,0,50,2,50,30,-2,32,45,3,30,25,2,0,35,2,20,50,
     X1,4,45,1,30,15,-3,16,50,2,30,25,1,1,40,4,10,50,2,8,30,4,45,50,3,0,
     X50,3,25,30,1,4,50,5,30,40,3,0,45,3,40,45,2,1,30,2,50,25,1,16,40,6,
     X25,50,4,8,30,5,30,40,2,5,20,6,45,60,3,0,40,5,50,70,3,1,10,7,80,80,
     X4,2,10,8,60,80,4,0,5,6,50,50,2,25,0,7,60,65,4,0,15,6,60,55,4,1,-10
     X,8,80,90,3,59/
	MDAM=IREQ(IMONST*6-1)
	NMHD=IREQ(IMONST*6-4)
	NROLL=NMHD
	MHITSM=0
	NBRETH=0
	ISWDPS=IAND(ICHAR(3),3)
	IF (NROLL .LT. 1) NROLL=1
	DO 10 IROLL=1,NROLL
 10	 MHITSM=MHITSM+RAN(I1,I2)*8+1
	MAXHTS=MHITSM
	IF (NMHD .LT. 1) MHITSM=-1*MHITSM/NMHD+1
	MHITSP=ICHAR(1)*8
	IHITM=IREQ(IMONST*6-5)+ICHAR(1)*10+IAND(ICHAR(3),3)*10
	IF (IHITM .GT. 95) IHITM=95
	IF ((IAND(IREQ(IMONST*6),1).NE.0).AND.(IAND(ICHAR(3),3)
     X	 .EQ. 0)) IHITM=0
	IHITP=IREQ(IMONST*6-2)-IAND(ICHAR(3),12)*5/2-IAND(ICHAR(3),48)
     X*5/4+IRUST*50
	IF (IHITP .LT. 5) IHITP=5
 40	ISAVEP=ICHAR(1)*5+30+IAND(ICHAR(3),256)/12.8
	IF (ISAVEP .GT. 95) ISAVEP=95
 50	IF ((ISWDPS.EQ.0).OR.(RAN(I1,I2).GT.ISWDPS/10.)) GOTO 60
	WRITE (5,900)
 900	FORMAT (1X,'YOUR MAGIC SWORD PIPES UP AND SAYS'/
     X	 ' ''OH BOY, A MONSTER. LET''S ATTACK.''')
	GO TO 100
 60	WRITE (5,901)
 901	FORMAT (1X,'WHAT DO YOU DO?')
	READ (5,902) BRESP
 902	FORMAT (4A1)
	GO TO (100,700,700,200,700,700,700,300,700,700,700,350,700,700,700,
     X	 700,700,400,500,700,600,700,700,700,700,700) (BRESP1-64)
	GOTO 700
 100	IATTK=RAN(I1,I2)*100+1
 	IF (IATTK .LE. IHITM) GO TO 105
 103	WRITE (5,920)
 920	FORMAT (1X,'YOU MISS')
	GO TO 400
 105	IDAM=RAN(I1,I2)*8+1+IAND(ICHAR(3),3)+IAND(ICHAR(3),16384)/3276.8
 110	MHITSM=MHITSM-IDAM
	WRITE (5,903)
 903	FORMAT (1X,'YOU HIT')
	IF (MHITSM .GE. 0) GO TO 400
 120	WRITE (5,904)
 904	FORMAT (1X,'THE MONSTER DIES')
	ICHAR(2)=ICHAR(2)+5*(1.25)**(IMONST-1)
	IMONST=0
	RETURN
 200	WRITE (5,905)
 905	FORMAT (1X,'A BOLT OF LIGHTNING CRASHES INTO THE ROOM,')
	IF (RAN(I1,I2) .GT. .2) GO TO 210
	WRITE (5,906)
 906	FORMAT (1X,'STRIKING THE MONSTER')
	GO TO 120
 210	WRITE (5,907)
 907	FORMAT (1X,'STRIKING YOU')
	CALL SDEAD
	RETURN
 300	WRITE (5,908) NHITS,MHITSP
 908	FORMAT (1X,'YOU HAVE TAKEN ',I2,' HITS OUT OF ',I2,' TOTAL')
 	GO TO 50
 350	CALL SBLIST
	GO TO 50
 400	SWDSTP=RAN(I1,I2)*10.
 	IF ((IAND(ICHAR(3),128).NE.0).AND.(BRESP1.EQ.82).AND.
     X	 (SWDSTP.GT.ISWDPS)) RETURN
	IF ((BRESP1.EQ.82).AND.(SWDSTP.LE.ISWDPS)) WRITE (5,931)
	IF ((IAND(IREQ(IMONST*6),8).EQ.0).OR.(MHITSM.GE.MAXHTS)) GOTO 
     X 401
	WRITE (5,927)
 927	FORMAT (1X,'SOME OF THE MONSTER''S WOUNDS SEEM TO BE HEALING')
	MHITS=MHITS+3
	IF (MHITSM .GT. MAXHTS) MHITSM=MAXHTS
 401	IF ((IAND(IREQ(IMONST*6),2).EQ.0).OR.(NBRETH.EQ.3)) GOTO 403
	IF (RAN(I1,I2) .GT. .45) GO TO 403
	NBRETH=NBRETH+1
	WRITE (5,923)
 923	FORMAT (1X,'A JET OF FLAME SPEWS FROM THE MONSTER')
	IDAM=IREQ(IMONST*6-4)*5
	IF (RAN(I1,I2)*100+1 .GT. ISAVEP) GO TO 402
	WRITE (5,924)
 924	FORMAT (1X,'YOU ARE ONLY GRAZED BY IT')
	IDAM=IDAM/5
 402	WRITE (5,925) IDAM
 925	FORMAT (1X,'YOU TAKE ',I2,' HITS')
	GO TO 420
 403	IATTK=RAN(I1,I2)*100+1
	IF (IATTK .LE. IHITP) GO TO 404
	WRITE (5,922)
 922	FORMAT (1X,'THE MONSTER MISSED')
	IF (BRESP1 .NE. 82) GOTO 50
 406	IF (ISWDPS .EQ. 0) RETURN
	WRITE (5,930)
 930	FORMAT (1X,'''CHICKEN'', SAYS YOUR SWORD')
	IF (SWDSTP .GT. ISWDPS) RETURN
	WRITE (5,931)
 931	FORMAT (1X,'''OH NO YOU DON''T'' HE CONTINUES,'/
     X	 ' ''YOU''RE STAYING RIGHT HERE AND FIGHTING.''')
	GO TO 50
 404	IF (IAND(IREQ(IMONST*6),16) .EQ. 0) GO TO 405
	WRITE (5,929)
 929	FORMAT (1X,'THE MONSTER''S POISON FANGS SINK INTO YOUR FLESH')
	IF (RAN(I1,I2)*100+1 .GT. ISAVEP) GO TO 425
	WRITE (5,928)
 928	FORMAT (1X,'NO POISON WAS INJECTED HOWEVER')
 405	ILOOP=MDAM
	IF (ILOOP .LT. 1) ILOOP=1
	IDAM=0
	DO 410 IROLL=1,ILOOP
 410	 IDAM=IDAM+RAN(I1,I2)*8+1
	IF (MDAM .LT. 1) IDAM=-1*IDAM/MDAM+1
	WRITE (5,909) IDAM
 909	FORMAT (1X,'THE MONSTER HITS, DELIVERING ',I2,' HITS')
 411	IF (IAND(IREQ(IMONST*6),4).EQ.0) GO TO 415
	IDRAIN=IREQ(IMONST*6-4)*500
	WRITE (5,926) IDRAIN
 926	FORMAT (1X,'THE ICY COLD TOUCH OF THE UNDEAD CHILLS YOU TO THE H
     XEART,'/' DRAINING SOME OF YOUR LIFE FORCE'/' YOU LOSE ',I4,
     X	 ' EXPERIENCE POINTS')
	ICHAR(2)=ICHAR(2)-IDRAIN
	IF (ICHAR(2) .GE. 0) GO TO 413
	ICHAR(2)=0
	CALL SDEAD
	RETURN
 413	CALL SCLIST(ICHAR)
 	MHITSP=ICHAR(1)*8
	GO TO 40
 415	IF ((IAND(IREQ(IMONST*6),32).EQ.0).OR.(IAND(ICHAR(3),12)
     X	 .NE.0).OR.(IRUST.EQ.1)) GO TO 420
	IRUST=1
	IHITP=IHITP+50
	WRITE (5,921)
 921	FORMAT (1X,'YOUR ARMOR HAS TURNED TO LITTLE FLAKES OF RUST'/
     X	 ' I''M AFRAID IT WON''T BE MUCH GOOD ANY MORE')
 420	NHITS=NHITS+IDAM
 	IF (NHITS .LE. MHITSP) GO TO 430
 425	CALL SDEAD
	RETURN
 430	IF (BRESP1 .EQ. 82) RETURN
	GO TO 50
 500	IF ((BRESP2 .NE. 67) .AND. (BRESP2 .NE. 70)) GO TO 700
	IF (NSPELL .GT. 0) GO TO 510
	WRITE (5,910)
 910	FORMAT (1X,'SORRY, YOU SEEM TO BE OUT OF SPELLS')
	GO TO 400
 510	NSPELL=NSPELL-1
	IF (BRESP2 .EQ. 70) GO TO 520
	NCURE=NHITS*RAN(I1,I2)+1
	WRITE (5,911) NCURE
 911	FORMAT (1X,'YOU HAVE CURED ',I2,' HITS.')
	NHITS=NHITS-NCURE
	GO TO 400
 520	IDAM=(ICHAR(1)+1)*8*RAN(I1,I2)+1
	ISAVE=RAN(I1,I2)*100+1
	IF (ISAVE .LT. IREQ(IMONST*6-3)) GO TO 103
	GO TO 110
 600	CALL SMLIST(ICHAR(3))
	IF (ICHAR(3) .EQ. 0) GO TO 50
	IRETRN=1
	CALL SMAGIT(IRETRN,BRESP(3),BRESP(4))
	IF (IRETRN .EQ. 1) GO TO 400
	IF (IRETRN .EQ. 3) GO TO 520
	IF (IRETRN .EQ. 2) IMONST=0
	RETURN
 700	WRITE (5,912)
 912	FORMAT (1X,'UNRECOGNIZED RESPONSE, TYPE LI FOR RECOGNIZED RESPON
     XSES')
	GO TO 50
	END
	SUBROUTINE SBLIST
	WRITE (5,901)
	WRITE (5,902)
	WRITE (5,903)
	WRITE (5,904)
	WRITE (5,905)
	WRITE (5,906)
	WRITE (5,907)
 901	FORMAT (1X,'AT  ATTACK')
 902	FORMAT (1X,'DI  CALL FOR DIVINE INTERVENTION')
 903	FORMAT (1X,'HT  HOW MANY HITS HAVE I TAKEN?')
 904	FORMAT (1X,'LI  DISPLAY THIS LIST')
 905	FORMAT (1X,'RE  PERFORM STRATEGIC RETREAT OUT OF BATTLE')
 906	FORMAT (1X,'S-  THROW SPELL:C - CURE,F - FIREBALL')
 907	FORMAT (1X,'UM  USE MAGIC ITEM')
	RETURN
	END
	SUBROUTINE SDEAD
	INTEGER*2 IROOM(250),ITEM(9)
	INTEGER*4 ICHAR(3)
	LOGICAL*1 LDFLAG
	BYTE BRESP
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM,
     X	 IUSED,MXITMS,LDFLAG
	WRITE (5,901)
 901	FORMAT (1X,'OH DEAR, YOU SEEM TO HAVE GOTTEN YOURSELF KILLED')
	WRITE (5,902)
 902	FORMAT (1X,'DO YOU WANT ME TO TRY AND RESURRECT YOU?')
	READ (5,903) BRESP
 903	FORMAT (A1)
	LDFLAG=.TRUE.
	IF (NITEM .EQ. 0) GO TO 20
	DO 10 I=1,NITEM
	LEVEL=RAN(I1,I2)*5+1
 10	CALL SRSTOR(ITEM(I),LEVEL)
 20	NITEM=0
	IF (BRESP .NE. 78) GO TO 100
	WRITE (5,904)
 904	FORMAT (1X,'REST IN PEACE')
 50	ICHAR(1)=1
	ICHAR(2)=0
	ICHAR(3)=0
	NITEM=0
	RETURN
 100	WRITE (5,905)
 905	FORMAT (1X,'OKAY, BUT I''M NOT VERY GOOD AT THIS SORT OF THING')
	WRITE (5,906)
 906	FORMAT (1X,'HERE GOES NOTHING . . . . . .')
	WRITE (5,907) "7,"7,"7
 907	FORMAT (1X,'***',A1,' POOF ******',A1,' BAM ******',A1,
     X	 ' KAZZZAAAPPPP ***')
	IF (RAN(I1,I2) .LT. .75) GO TO 200
	WRITE (5,908)
 908	FORMAT (1X,'************ BOOOOOOOIIIIINNNNGGGGGGG *******')
	WRITE (5,909)
 909	FORMAT (1X,'OOPS, I SEEM TO HAVE GOOFED, THAT WAS THE SPELL
     X FOR REMOVING WARTS. AND IT''S TOO LATE TO TRY AGAIN.')
	WRITE (5,910)
 910	FORMAT (1X,'SORRY ABOUT THAT. BETTER LUCK NEXT TIME.')
	GO TO 50
 200	WRITE (5,911)
 911	FORMAT (1X,'********** POP ***********')
	WRITE (5,912)
 912	FORMAT (1X,'I DID IT. ALIVE AND KICKING')
	WRITE (5,913)
 913	FORMAT (1X,'YOU LOOK A LITTLE PEAKED THOUGH.')
	WRITE (5,914)
 914	FORMAT (1X,'BETTER GET SOME REST AND COME BACK TOMORROW')
	WRITE (5,915)
 915	FORMAT (1X,'SORRY I COULDN''T SAVE YOUR BACKPACK')
	RETURN
	END
	SUBROUTINE SRANDE(I1,I2,Y,AVG,DEV)
	B=DEV*AVG/.693147
 10	ISIGNX=ININT(RAN(I1,I2))
	Y=AVG+B*ALOG(1.-RAN(I1,I2))*(-1)**ISIGNX
	IF (Y .LE. 0.) GO TO 10
	RETURN
	END
	SUBROUTINE SRSTOR(IWORD,ILEV)
	INTEGER*2 IROOM(250),ITEM(9)
	INTEGER*4 ICHAR(3)
	LOGICAL*1 LDFLAG
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM
     X	 ,IUSED,MXITMS,LDFLAG
	IF (IWORD .EQ. 0) RETURN
	IMASK=32767
	IF (IAND(IWORD,32512) .EQ. 0) IMASK=255
	IF (IAND(IWORD,255) .EQ. 0) IMASK=32512
	NSROOM=RAN(I1,I2)*50+1
	NRMP50=NSROOM+50
	DO 100 I=NSROOM,NRMP50
	 NROOM=MOD(I,50)+ILEV*50-49	!CHG 9/23 BY A.V.G., WAS 100-99
D	WRITE(5,1001)NROOM
1001	FORMAT(' NROOM=',I5)
 100	 IF (IAND(IROOM(NROOM),IMASK) .EQ. 0) GO TO 200
	RETURN
 200	IROOM(NROOM)=IOR(IROOM(NROOM),IWORD)
	IWORD=0
	RETURN
	END
	SUBROUTINE SEND
	INTEGER*2 IROOM(250),ITEM(9)
	LOGICAL*1 LDFLAG
	INTEGER*4 ICHAR(3)
	BYTE BNAME(18),CNAME(18),DNAME(18)
	INTEGER*4	TNAME(10)
	COMMON /DANDD2/IROOM,IRUST,I1,I2,NHITS,ICHAR,NSPELL,ITEM,NITEM
     X	 ,IUSED,MXITMS,LDFLAG
	COMMON /DANDD3/BNAME,CNAME,DNAME,TNAME
C
C   TFACT HAS POWERFUL EFFECT ON TREASURE VALUE.  CHANGE IT SLIGHTLY TO
C	MAKE TREASURE POINTS VARY ON THE AVERAGE.  IT IS RAISED EXPONENTIALLY
	DATA 	TFACT/1.35/
C
C	BY TREASURE VALUE.
	IF (NITEM .LE. 0) GO TO 25
	DO 20 I=1,NITEM
	 IMAGIC=0
	 ITREAS=0
	 IF (ITEM(I) .GT. 200) GO TO 10
	 IF (ITEM(I) .LE. 200) ITREAS=ITEM(I)
	 CALL SRANDE(I1,I2,Y,100.*(TFACT)**(ITREAS-1),.5)
	 ICHAR(2)=ICHAR(2)+Y
	 GO TO 20
 10	 IMAGIC=ITEM(I)-200
 	 IF (IMAGIC .GT. 6) GO TO 15
	 IBITS=((IMAGIC-1)/2)*2
	 IABSV=MOD((IMAGIC-1),2)+1
	 IMASK=3*2**IBITS
	 IALR=IAND(ICHAR(3),IMASK)
	 IREP=IABSV*2**IBITS
	 IF (IREP .GT. IALR) ICHAR(3)=ICHAR(3)-IALR+IREP
	 GO TO 20
 15	 IMASK=2**(IMAGIC-1)
	 ICHAR(3)=IOR(ICHAR(3),IMASK)
 20	 CONTINUE
 25	CALL SCLIST(ICHAR)
	CALL SMLIST(ICHAR(3))
	CALL SRANDE(I1,I2,Y,6.,.5)
	NMON=Y+1
	DO 35 MONST=1,NMON
	 ILEV=RAN(I1,I2)*5+1
 30	 CALL SRANDE(I1,I2,Y,ILEV*6.+2.,1./ILEV)
	 IF (Y .GE. 30) GO TO 30
	 IY=Y+1
	 IMONST=IY*256
 35	 CALL SRSTOR(IMONST,ILEV)
	OPEN (UNIT=3,NAME=BNAME,TYPE='UNKNOWN',FORM='UNFORMATTED')
	WRITE (3) (IROOM(I),I=1,250)
	CLOSE (UNIT=3)
	OPEN (UNIT=3,NAME=CNAME,TYPE='OLD',FORM='UNFORMATTED')
 	WRITE (3) (ICHAR(I),I=1,3)
	CLOSE (UNIT=3)
	WRITE (5,910)
 910	FORMAT (1X,'EXPEDITION ENDED')
	RETURN
	END
C  SUBROUTINE FOR RESETTING THE DUNGEON PARAMETERS
	SUBROUTINE RESET(BINIT,BMOD)
	LOGICAL*1 LRFLAG
	BYTE BMOD,BRESP,BINIT(3)
	I1=SECNDS(0.)/3.7
	I2=SECNDS(0.)/7.3
	WRITE (5,904)
 904	FORMAT (1X,'ENTER YOUR THREE INITIALS')
	READ (5,911) BINIT
	IF (BMOD.EQ.65) GOTO 200	!RESET ALL IF BMOD IS 'A'
 911	FORMAT (3A1)
 100	WRITE (5,901)
 901	FORMAT(1X,'WHICH OF THE FOLLOWING DO YOU WISH TO CHANGE:'
     X	 /' 	A: ALL (TOTALLY NEW CAMPAIGN)'
     X	 /' 	C: CHARACTER (EXPERIENCE AND MAGIC ITEMS TO ZERO)'
     X	 /' 	M: MAP (PATTERN OF CORRIDORS AND ROOMS)'
     X	 /' 	N: NO MORE CHANGES'
     X	 /' 	R: ROOMS (REFILL WITH MONSTERS AND TREASURES)')
	READ (5,910) BMOD
 910	FORMAT (A1)
	IF ((BMOD.LT.65).OR.(BMOD.GT.82)) GOTO 700
	GOTO (200,700,200,700,700,700,700,700,700,700,700,700,300,
     X	 800,700,700,700,400) (BMOD-64)
 200	CALL SCHAR(BINIT)
	IF (BMOD .NE. 65) GO TO 600
 300	CALL SCORRS(5)
	CALL SADDRM(BINIT,5)
	IF (BMOD .NE. 65) GO TO 600
 400	CALL SFILLD(BINIT,50,5,I1,I2)
	IF (BMOD.EQ.65) GOTO 800		!RETURN IF ALL RESET
 600	WRITE (5,902)
 902	FORMAT (1X,'DO YOU WISH TO MAKE FURTHER CHANGES ?')
	READ (5,910) BRESP
	IF (BRESP .NE. 78) GO TO 100
 800	RETURN
 700	WRITE (5,903)
 903	FORMAT (1X,'UNRECOGNIZED RESPONSE')
	GO TO 100
	END
	SUBROUTINE SCHAR(BINIT)
	BYTE BINIT(3),CNAME(18)
	INTEGER*4 I4CHAR(3)
	DATA CNAME/'S','I','A','0',':','C','H','A','R','F','I',
     X	 'L','E','.',0,0,0,0/
	DO 10 I=1,3
 10	 CNAME(I+14)=BINIT(I)
	OPEN (UNIT=1,NAME=CNAME,TYPE='UNKNOWN',FORM='UNFORMATTED')
	I4CHAR(1)=1
	I4CHAR(2)=0
	I4CHAR(3)=0
	WRITE (1) (I4CHAR(J), J=1,3)
	CLOSE (UNIT=1)
	RETURN
	END
	SUBROUTINE SFILLD(BINIT,NROOMS,NLEVS)
	INTEGER*2 IBUFFR(250)
	BYTE BNAME(18),BINIT(3)
	DATA BNAME/'S','I','A','0',':','R','O','O','M','F','I',
     X	 'L','E','.',0,0,0,0/
	DO 10 I=1,3
 10	 BNAME(I+14)=BINIT(I)
	DO 100 I=1,250
 100	IBUFFR(I)=0
	DO 700 ILEV=1,NLEVS
	 RMNAVG=ILEV*6.-2.
	 RDEV=1./ILEV
	 DO 600 IROOM=1,NROOMS
 200	  CALL SRANDE(I1,I2,Y,RMNAVG,RDEV)
	  IF (Y .GE. 30.) GO TO 200
	  IY=Y+1.
	  IMONST=IY*256
	  IF (RAN(I1,I2) .LT. .15) IMONST=0
	  RTSAVG=IY*2.5/6.+2.
	  RMGAVG=IY/3.+1.
	  IF (IMONST .EQ. 0) RTSAVG=1.
	  IF (IMONST .EQ. 0) RMGAVG=1.
	  IF (RAN(I1,I2) .LT. .2) GO TO 400
 300	  CALL SRANDE(I1,I2,Y,RTSAVG,RDEV)
	  IF (Y .GE. 16.) GO TO 300
	  ITREAS=Y
	  GO TO 600
 400	  CALL SRANDE(I1,I2,Y,RMGAVG,1.)
	  IF (Y .GE. 16.) GO TO 400
	  IY=Y
	  ITREAS=IY+200
	IF (IY .EQ. 0) ITREAS=0
 600	  IBUFFR((ILEV-1)*NROOMS+IROOM)=IMONST+ITREAS
 700	 CONTINUE
	OPEN (UNIT=3,NAME=BNAME,TYPE='UNKNOWN',FORM='UNFORMATTED')
	WRITE (3) (IBUFFR(I),I=1,250)
	CLOSE (UNIT=3)
	RETURN
	END
	SUBROUTINE SCORRS(NLEVS)
	INTEGER*2 IIBUFS(5,250),IBLOCK(50,50),ITREE(50,7),ISIDE(2)
	COMMON /DANDD4/IIBUFS,I1,I2
	DO 750 ILEV=1,NLEVS
	 DO 10 ISET=1,50
	  DO 5 JSET=1,50
 5	   IBLOCK(ISET,JSET)=0
	  DO 10 JSET=1,7
 10	   ITREE(ISET,JSET)=0
	 ILOC=2
	 IMAX=2
	 ICD=RAN(I1,I2)*50+1
	 JCD=RAN(I1,I2)*50+1
	 IBLOCK(ICD,JCD)=52
	 ITREE(2,6)=ICD
	 ITREE(2,7)=JCD
	 IDIR=RAN(I1,I2)*4+2
	 ITREE(2,1)=5632+2**(IDIR-2)
	 ITREE(2,IDIR)=-1
	 IF (ILEV .NE. 1) GO TO 100
	 IACR=IDIR+(-1)**IDIR
	 ITREE(2,IDIR)=51
	 ITREE(1,1)=2048+2**(IACR-2)
	 ITREE(1,IACR)=52
 100	 DO 500 IDIR=2,5
	  ICD=ITREE(ILOC,6)
	  JCD=ITREE(ILOC,7)
	  IF ((ITREE(ILOC,IDIR).NE.0).OR.(RAN(I1,I2).GE..5)) GOTO 500
	  ICDINC=(IDIR/2-1)*(-1)**IDIR
	  JCDINC=(IDIR/2-2)*(-1)**(IDIR-1)
	  IF (IBLOCK(ICD+ICDINC,JCD+JCDINC).NE.0) GO TO 500
	  IDREM=MOD(IDIR-1,2)*50-ICDINC*ICD-JCDINC*JCD-MOD(IDIR,2)
	  IF (IDREM .LT. 2) GO TO 500
	  IRUN=RAN(I1,I2)*(IDREM-1)+1
	  IF (ITREE(ILOC,1).LT.1280) ITREE(ILOC,1)=ITREE(ILOC,1)+256
	  ITREE(ILOC,1)=ITREE(ILOC,1)+16*2**(IDIR-2)
	  IACR=IDIR+(-1)**IDIR
	  DO 200 IMOVE=1,IRUN
	   ICD=ICD+ICDINC
	   JCD=JCD+JCDINC
	   IF (IBLOCK(ICD,JCD) .NE. 0) GO TO 250
 200	   IBLOCK(ICD,JCD)=-1
	  ICD=ICD+ICDINC
	  JCD=JCD+JCDINC
	  IF (IBLOCK(ICD,JCD) .NE. 0) GO TO 250
	  IMAX=IMAX+1
	  ITREE(ILOC,IDIR)=IMAX+50
	  IBLOCK(ICD,JCD)=IMAX+50
	  ITREE(IMAX,6)=ICD
	  ITREE(IMAX,7)=JCD
	  ITREE(IMAX,1)=256+16*2**(IACR-2)
	  ITREE(IMAX,IACR)=ILOC+50
	  IF (IMAX .EQ. 49) GO TO 600
	  GO TO 500
 250	  IF (IBLOCK(ICD,JCD) .EQ. -1) GO TO 300
	  IBACK=IBLOCK(ICD,JCD)-50
	  ITREE(ILOC,IDIR)=IBACK+50
	  IF (ITREE(IBACK,1).LT.1280) ITREE(IBACK,1)=ITREE(IBACK,1)+256
	  ITREE(IBACK,1)=ITREE(IBACK,1)+16*2**(IACR-2)
	  ITREE(IBACK,IACR)=ILOC+50
	  GO TO 500
 300	  IMAX=IMAX+1
	  ITREE(ILOC,IDIR)=IMAX+50
	  ITREE(IMAX,IACR)=ILOC+50
	  IBLOCK(ICD,JCD)=IMAX+50
	  ITREE(IMAX,6)=ICD
	  ITREE(IMAX,7)=JCD
	  ISIDE(1)=2*(3-IDIR/2)
	  ISIDE(2)=ISIDE(1)+1
	  ITREE(IMAX,1)=768+16*(2**(IACR-2)+2**(ISIDE(1)-2)+2**(ISIDE(2)
     X	   -2))
	  DO 350 ISD=1,2
	   ICDINC=(ISIDE(ISD)/2-1)*(-1)**ISIDE(ISD)
	   JCDINC=(ISIDE(ISD)/2-2)*(-1)**(ISIDE(ISD)-1)
	   ICD2=ICD
	   JCD2=JCD
	   DO 310 IMOVE=1,51
	    ICD2=ICD2+ICDINC
	    JCD2=JCD2+JCDINC
 310	    IF (IBLOCK(ICD2,JCD2).NE.-1) GO TO 320
 320	   IBACK=IBLOCK(ICD2,JCD2)
	   IACR2=ISIDE(3-ISD)
	   ITREE(IMAX,ISIDE(ISD))=IBACK
 350	   ITREE(IBACK-50,IACR2)=IMAX+50
	  IF (IMAX .GE. 49) GO TO 600
 500	  CONTINUE
	 ILOC=ILOC+1
	 IF (ILOC .LE. IMAX) GO TO 100
	 ILOC=RAN(I1,I2)*(ILOC-3)+2
	 GO TO 100
 600	 IF (ILEV .EQ. NLEVS) GO TO 700
	 IDIR=RAN(I1,I2)*4+2
 610	 IDIR=MOD(IDIR-1,4)+2
	 IF (ITREE(49,IDIR) .NE. 0) GO TO 610
	 ITREE(49,1)=1536+IAND(ITREE(49,1),240)+2**(IDIR-2)
	 ITREE(49,IDIR)=152
 700	 DO 740 IMOVE=1,50
	  DO 740 JMOVE=1,5
 740	   IIBUFS(ILEV,(IMOVE-1)*5+JMOVE)=ITREE(IMOVE,JMOVE)
 750	CONTINUE
	RETURN
	END
	SUBROUTINE SADDRM(BINIT,NLEV)
	INTEGER*2 IIBUFS(5,250),IOBUF(500)
	LOGICAL*1 LRFLAG
	BYTE DNAME(18),BINIT(3)
	COMMON /DANDD4/IIBUFS,IR1,IR2
	COMMON /DANDD5/IOBUF,ILEV,LRFLAG
	DATA DNAME/'S','I','A','0',':','D','A','T','A','F','I',
     X	 'L','E','.',0,0,0,0/
	DO 10 I=1,3
 10	 DNAME(I+14)=BINIT(I)
	OPEN (UNIT=1,NAME=DNAME,TYPE='UNKNOWN',FORM='UNFORMATTED')
	DO 300 ILEV=1,NLEV
	 IRMCTR=1
	 LRFLAG=.FALSE.
	 DO 100 I=1,500
 100	  IOBUF(I)=0
 150	 DO 200 INODE=3,48
	  IMAIN=INODE*5-4
	  DO 190 ILINK=1,4
	   IPT=ILINK+IMAIN
	   IF ((RAN(IR1,IR2).LT..1).AND.(IIBUFS(ILEV,IPT).NE.
     X	    0)) CALL SRMBTN(IRMCTR,50,INODE,ILINK)
	   IF ((RAN(IR1,IR2).LT..28).AND.(IIBUFS(ILEV,IPT).EQ.
     X	    0)) CALL SRMTCR(IRMCTR,50,INODE,ILINK)
 190	   IF (LRFLAG) GO TO 230
 200	  CONTINUE
	 GO TO 150
 230	 DO 250 ICOR=1,250
 250	  IOBUF(ICOR+250)=IIBUFS(ILEV,ICOR)
	 IMODFY=(ILEV-1)*100
	 DO 280 IWORD=1,400
	  ILINKS=((IWORD-1)*5)/4+2
 280	  IF (IOBUF(ILINKS).NE.0) IOBUF(ILINKS)=IOBUF(ILINKS)+IMODFY
 300	 WRITE (1) (IOBUF(I),I=1,500)
	CLOSE (UNIT=1)
	RETURN
	END
	SUBROUTINE SRMBTN(IRMCTR,IRMMAX,INODE1,ILINK1)
	INTEGER*2 IIBUFS(5,250),IOBUF(500)
	LOGICAL*1 LRFLAG
	COMMON /DANDD4/IIBUFS,IR1,IR2
	COMMON /DANDD5/IOBUF,ILEV,LRFLAG
	IMAIN1=INODE1*5-4
	IPT1=IMAIN1+ILINK1
	INODE2=IIBUFS(ILEV,IPT1)-50
	IMAIN2=INODE2*5-4
	IACR1=ILINK1-(-1)**ILINK1
	DO 100 ILINK2=1,4
	 IPT2=IMAIN2+ILINK2
 100	 IF (IIBUFS(ILEV,IPT2).EQ.(INODE1+50)) GOTO 200
	ILINK2=IACR1
	IPT2=IMAIN2+ILINK2
 200	IACR2=ILINK2-(-1)**ILINK2
	ITYPE1=IAND(IIBUFS(ILEV,IMAIN1),3840)/256
	ITYPE2=IAND(IIBUFS(ILEV,IMAIN2),3840)/256
	IF ((ITYPE1.EQ.1).OR.(ITYPE1.GE.5).OR.(ITYPE2.EQ.1).OR.
     X	 (ITYPE2.GE.5)) RETURN
	IIBUFS(ILEV,IPT1)=IRMCTR
	IIBUFS(ILEV,IMAIN1)=IAND(IIBUFS(ILEV,IMAIN1),255)+1280-
     X	 15*2**(ILINK1-1)
	IIBUFS(ILEV,IPT2)=IRMCTR
	IIBUFS(ILEV,IMAIN2)=IAND(IIBUFS(ILEV,IMAIN2),255)
     X	 +1280-15*2**(ILINK2-1)
	IOBUF(IRMCTR*5-4)=1792+(2**IACR1+2**IACR2)/2
	IOBUF(IRMCTR*5-4+IACR2)=INODE2+50
	IOBUF(IRMCTR*5-4+IACR1)=INODE1+50
	IRMCTR=IRMCTR+1
	IF (IRMCTR .GT. IRMMAX) GO TO 800
	CALL SRMTRM(IRMCTR,IRMMAX)
	RETURN
 800	LRFLAG=.TRUE.
	RETURN
	END
	SUBROUTINE SRMTCR(IRMCTR,IRMMAX,INODE,ILINK)
	INTEGER*2 IIBUFS(5,250),IOBUF(500)
	LOGICAL*1 LRFLAG
	COMMON /DANDD4/IIBUFS,IR1,IR2
	COMMON /DANDD5/IOBUF,ILEV,LRFLAG
	IMAIN=INODE*5-4
	IPT=IMAIN+ILINK
	IIBUFS(ILEV,IPT)=IRMCTR
	IIBUFS(ILEV,IMAIN)=IAND(IIBUFS(ILEV,IMAIN),255)+1280+
     X	 2**(ILINK-1)
	IACROS=ILINK-(-1)**ILINK
	IOBUF(IRMCTR*5-4)=1792+2**(IACROS-1)
	IOBUF(IRMCTR*5-4+IACROS)=INODE+50
	IRMCTR=IRMCTR+1
	IF (IRMCTR .GT. IRMMAX) GO TO 800
	CALL SRMTRM(IRMCTR,IRMMAX)
	RETURN
 800	LRFLAG=.TRUE.
	RETURN
	END
	SUBROUTINE SRMTRM(IRMCTR,IRMMAX)
	INTEGER*2 IIBUFS(5,250),IOBUF(500)
	LOGICAL*1 LRFLAG
	COMMON /DANDD4/IIBUFS,IR1,IR2
	COMMON /DANDD5/IOBUF,ILEV,LRFLAG
	NODE=IRMCTR-2
 100	NODE=NODE+1
	MAIN=NODE*5-4
	DO 200 LINK=1,4
	 IPT=MAIN+LINK
	 IF ((IOBUF(IPT).NE.0).OR.(RAN(IR1,IR2).GT..126))GOTO 200
	 IOBUF(IPT)=IRMCTR
	 IACROS=LINK-(-1)**LINK
	 IOBUF(MAIN)=IOBUF(MAIN)+2**(LINK-1)
	 IOBUF(IRMCTR*5-4)=1792+2**(IACROS-1)
	 IOBUF(IRMCTR*5-4+IACROS)=NODE
	 IRMCTR=IRMCTR+1
	 IF (IRMCTR .GT. IRMMAX) GO TO 800
 200	 CONTINUE
	IF (NODE .LT. IRMCTR-1) GO TO 100
	RETURN
 800	LRFLAG=.TRUE.
	RETURN
	END
