Fortran JIOR

Post Reply

Topic author
afassl
Active Contributor
Posts: 27
Joined: Fri Jun 14, 2019 3:15 am
Reputation: 0
Status: Offline

Fortran JIOR

Post by afassl » Wed May 10, 2023 8:25 am

Hi all,

I'm just trying to compile a little piece of ancient FORTRAN code.

Code: Select all

C               Manufacture QIO command with NOECHO and TIMED modifiers.
                TIMED_IO = JIOR(%LOC(IO$_READLBLK),%LOC(IO$M_TIMED))
                TIMED_IO = JIOR(TIMED_IO,%LOC(IO$M_NOECHO))
Linker complains:

Code: Select all

%ILINK-W-COMPWARN, compilation warnings
	module: INVADERS 
	file: DKA400:<INCOMING.INVADERS>INVADER.OBJ;4 
%ILINK-W-NUDFSYMS, 1 undefined symbol:
%ILINK-I-UDFSYM, 	JIOR 
%ILINK-W-USEUNDEF, undefined symbol JIOR referenced
	section: $CODE$
	offset: %X00000000000031A5
	module: INVADERS 
	file: DKA400:<INCOMING.INVADERS>INVADER.OBJ;4 
%ILINK-W-USEUNDEF, undefined symbol JIOR referenced
	section: $CODE$
	offset: %X00000000000031D6
	module: INVADERS 
	file: DKA400:<INCOMING.INVADERS>INVADER.OBJ;4 
Just a simple program to play ... space invaders :-)

any idea?

Best regards
Andreas

Added in 5 minutes 4 seconds:
Hm,

found this link:
https://uprrp2.uprrp.edu/help?key=FORTR ... p&referer=

so I've replaced JIOR with IOR.

COmpiles and runs, but looks like the timing isn't working.

User avatar

arne_v
Master
Posts: 308
Joined: Fri Apr 17, 2020 7:31 pm
Reputation: 0
Location: Rhode Island, USA
Status: Offline
Contact:

Re: Fortran JIOR

Post by arne_v » Wed May 10, 2023 10:21 am

JIOR should work.

IOR works for any INTEGER, IIOR for INTEGER*2, JIOR for INTEGER*4 and KIOR for INTEGER*8.

IOR is fine, but JIOR should still be there.

Unless there is a:

EXTERNAL JIOR

in the code.

If there is no such EXTERNAL then the missing JIOR would be a compiler bug IMHO.
Last edited by arne_v on Wed May 10, 2023 10:37 am, edited 1 time in total.
Arne
arne@vajhoej.dk
VMS user since 1986


elementyl
Newbie
Posts: 4
Joined: Wed May 10, 2023 10:44 pm
Reputation: 0
Status: Offline

Re: Fortran JIOR

Post by elementyl » Wed May 10, 2023 10:52 pm

afassl wrote:
Wed May 10, 2023 8:30 am

I'm just trying to compile a little piece of ancient FORTRAN code.

Code: Select all

C               Manufacture QIO command with NOECHO and TIMED modifiers.
                TIMED_IO = JIOR(%LOC(IO$_READLBLK),%LOC(IO$M_TIMED))
                TIMED_IO = JIOR(TIMED_IO,%LOC(IO$M_NOECHO))
[...]
I've replaced JIOR with IOR.

COmpiles and runs, but looks like the timing isn't working.
Assuming you are passing TIMED_IO by value to $QIO, get rid of the %LOC(). Also not sure why it uses IO$_READLBLK rather than IO$_READVBLK, but you didn't post the actual $QIO call.


Topic author
afassl
Active Contributor
Posts: 27
Joined: Fri Jun 14, 2019 3:15 am
Reputation: 0
Status: Offline

Re: Fortran JIOR

Post by afassl » Thu May 11, 2023 8:46 am

Code: Select all

			Video Terminal Space Invaders
C
C	Originally written in C by Jude Miller, 1979, Cambridge.
C	Translated to FORTRAN-77 by Jonathan Boswell, July '81
C	at the University of Virginia, Charlottesville, Virginia.
C
C	Machine dependent subroutines are SLEEP, CLEAR, MOVE, SPECIAL_GRAPHIC,
C	and FUNCTION INCHAR.  These subroutines are written for a VAX/VMS
C	operating system employing VT100 terminals.
C
	PROGRAM INVADERS
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL
	DATA GAME,SCORES,BASES,DANGER,MAX_DANGER,MAX_BOMB_ROW,SLOW
	1 /0,0,3,11,22,20,.FALSE./

	CALL CLEAR
	CALL MOVE(5,0)
	TYPE*,'Attention: Alien invasion in progress!'
	TYPE*
	TYPE*,'Instructions:   <1>     to move the laser base left'
	TYPE*,'                <2>     to halt the laser base'
	TYPE*,'                <3>     to move the laser base right'
	TYPE*,'                <space> to fire a laser beam'
	TYPE*,'                <Q>     to quit'
	TYPE*
	TYPE*,'        Type:   <1>     to play Bloodbath'
	TYPE*,'                <2>     to play We Come in Peace'
	TYPE*,'                <3>     to play Invasion of the Aliens'
	TYPE*,'                <4>     to play Invisible Alien Weasels'
	ACCEPT*,GAME

	CALL SPECIAL_GRAPHIC(.TRUE.)
1	CALL TABLEAU	!Draw starting game tableau.
	CALL SLEEP('04.00')	!Pause a few seconds.
2	CALL COMMAND	!See if there's a command waiting.
	CALL BEAM	!Update laser beam.
	CALL BASE	!Slide laser base around.
	CALL BOMB	!Drop alien bombs.
	CALL SHIP	!Fly mystery ship across top of screen.
	CALL ADVANCE	!Advance an alien.
	CALL ADVANCE	!Advance another alien.
	IF (ALIENS_LEFT.EQ.0)   GO TO 1
	GO TO 2
	END


	SUBROUTINE TABLEAU
C	Tableau draws the starting game tableau.
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL
	CHARACTER*80 INIT_BARR(4)
	DATA INIT_BARR/
	1'         lwwwwwwk          lklklklk          lklklklk
	2          lwwwwwwk         ',
	3'        lnnvvvvnnk        lvnvvvvnvk        lvnvvvvnvk
	4        lnnvvvvnnk       ',
	5'        tnu    tnu        tqu    tqu        tqu    tqu
	6        tnu    tnu       ',
	7'        mvj    mvj        mqj    mqj        mqj    mqj
	8        mvj    mvj        '/
	CALL CLEAR
	CALL MOVE(0,0)
	CALL SEND('SCORE:')
	CALL SEND_INT(SCORES)
	CALL MOVE(0,18)
	CALL SEND('I N V A S I O N   O F   T H E   A L I E N S !')
	CALL MOVE(0,70)
	CALL SEND('BASES:')
	CALL SEND_INT(BASES)

C	Initialize alien co-ords, display !
	ALIENS_LEFT = 55

	DO 20 J=0,4
		CALL MOVE(DANGER-(2*J),0)
		DO 20 I=1,11
			CALL DS_OBJ(((I+J).AND.1)+(2*(J/2)))
			CALL SEND(' ')
			ALIEN_ROW(11*J+I) = DANGER - (2*J)
20			ALIEN_COL(11*J+I) = 6*(I-1)
	ALIEN = 55
	FLIP = .FALSE.
	FLOP = .FALSE.
	LEFT = .FALSE.

C	Initialize laser base position, velocity.
	BASE_ROW = 23
	BASE_COL = 72
	BASE_VEL = -1
	BEAM_ROW = 0
	CALL MOVE(BASE_ROW,BASE_COL)
	CALL DS_OBJ(7)

C	Initialize bomb arrays. (ROW = 0 implies empty)
	DO 30 I=1,MAX_BOMBS
30	BOMB_ROW(I) = 0
	B = 0
	FALLING_BOMBS = 0

C	Initialize barricades.
	DO 40 I=MAX(1,DANGER-17),4
		CALL MOVE(I+18,0)
		CALL SEND(INIT_BARR(I))
40		BARR(I)=INIT_BARR(I)	!String assignment, 1 to 80.
	DANGER=MIN(MAX_DANGER,DANGER+1) !Get ready for next set of aliens.

C	Initialize mystery ships.
	SHIP_VEL = 0
	RETURN
	END


	SUBROUTINE SLEEP(TAG)
C	Set timer and wait for TAG seconds.  TAG is a CHARACTER*5 string
C	of the form ##.##, which is the seconds, and hundredths of seconds.
C	To delay game for 5 seconds, TAG would be '05.00'.
	IMPLICIT INTEGER*4 (A-Z)
	EXTERNAL SS$_NORMAL
	DOUBLE PRECISION TIME
	CHARACTER DELTA_TIME*9,TAG*5

	DELTA_TIME='0 ::'//TAG		!Concatenate strings.
	RET_STAT=SYS$BINTIM(DELTA_TIME,TIME)	!ASCII to binary time.
	IF(RET_STAT.NE.%LOC(SS$_NORMAL))STOP'BINTIM failed.'
	RET_STAT=SYS$SETIMR(,TIME,,)		!Set timer, event flag 0.
	IF(RET_STAT.NE.%LOC(SS$_NORMAL))STOP'SETIMR failed.'
	RET_STAT=SYS$WAITFR(%VAL(0))		!Wait for flag 0 to be set.
	IF(RET_STAT.NE.%LOC(SS$_NORMAL))STOP'WAITFR failed.'
	RETURN
	END


	SUBROUTINE COMMAND
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL
	BYTE INCHAR,INPT

	IF(SLOW)CALL SLEEP('04.00')	!Use all five characters.
	IF (GAME.EQ.1) THEN
		IF (BASE_COL.LE.1)   BASE_VEL = 1
		IF (BASE_COL.GE.72)  BASE_VEL = -1
		ENDIF

	INPT=INCHAR()		!Take in character from keyboard.
	IF(INPT.EQ.' ')THEN
		IF (BEAM_ROW.EQ.0)   BEAM_ROW = 23
		RETURN
	ELSE IF(INPT.EQ.'Q'.OR.INPT.EQ.'q')THEN
		CALL HALT
		ENDIF
	IF(GAME.EQ.1)RETURN
	IF(INPT.LE.'3'.AND.INPT.GE.'1') BASE_VEL=INPT-ICHAR('2')
	RETURN
	END


	BYTE FUNCTION INCHAR()
C	Take in single character from terminal, but don't wait if
C	it isn't there.
	IMPLICIT INTEGER*4 (A-Z)
	INTEGER*2 TTIOSB(4)
	EXTERNAL IO$_READLBLK,IO$M_TIMED,IO$M_NOECHO
	EXTERNAL SS$_NORMAL,SS$_TIMEOUT
	CHARACTER*63 TERMINAL
	LOGICAL FIRST
	DATA FIRST/.TRUE./

	IF(FIRST)THEN
C		Find out what terminal we're on.
		SSCODE=SYS$TRNLOG('TT',,TERMINAL,,,)
		IF(SSCODE.NE.%LOC(SS$_NORMAL))STOP'Translation failure.'
C		Assign channel.
		SSCODE=SYS$ASSIGN(TERMINAL,TT_CHAN,,)
		IF(SSCODE.NE.%LOC(SS$_NORMAL))STOP'Assignment failure.'
		FIRST=.FALSE.
C		Manufacture QIO command with NOECHO and TIMED modifiers.
		TIMED_IO = IOR(%LOC(IO$_READLBLK),%LOC(IO$M_TIMED))
		TIMED_IO = IOR(TIMED_IO,%LOC(IO$M_NOECHO))
		ENDIF

C	Read character from TT_CHAN into INCHAR with 0 timeout.
1	SSCODE=SYS$QIOW(%VAL(0),%VAL(TT_CHAN),%VAL(TIMED_IO)
	1 ,TTIOSB,,,INCHAR,%VAL(1),%VAL(0),,,)
	IF(SSCODE.NE.%LOC(SS$_NORMAL))STOP'QIO argument error.'

	ERROR=TTIOSB(1)
	IF(ERROR.EQ.%LOC(SS$_TIMEOUT)) THEN
		INCHAR=0
		RETURN
		ENDIF
	IF(ERROR.EQ.%LOC(SS$_NORMAL)) RETURN
	STOP'QIO return error.'
	END


	SUBROUTINE BASE
C	Move laser base left or right.
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL

	OLD_COL=BASE_COL
	BASE_COL=BASE_COL+BASE_VEL
	IF (BASE_COL.LT.1) THEN
		BASE_COL = 1
	ELSE IF (BASE_COL.GT.72) THEN
		BASE_COL = 72
		ENDIF
	IF (BASE_COL.EQ.OLDCOL) RETURN
	CALL MOVE(BASE_ROW,BASE_COL)
	CALL DS_OBJ(7)
	RETURN
	END



	SUBROUTINE BEAM
C	Activate or advance the laser beam if required.
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL

C	Display beam
	IF(BEAM_ROW.EQ.0)RETURN
	BEAM_ROW=MAX(BEAM_ROW-1,0)	!Increment beam position.
	IF(BEAM_ROW.EQ.0)THEN		!Erase beam, return.
		CALL MOVE(1,BEAM_COL)
		CALL SEND(' '//CHAR(8)//CHAR(10)//' ')
		RETURN
	ELSE IF(BEAM_ROW.EQ.21)THEN
		CALL MOVE(21,BEAM_COL)
		CALL SEND('x')
	ELSE IF(BEAM_ROW.EQ.22)THEN
		BEAM_COL = BASE_COL + 3
		CALL MOVE(22,BEAM_COL)
		CALL SEND('x')
	ELSE
		CALL MOVE(BEAM_ROW,BEAM_COL)
		CALL SEND('x'//CHAR(8)//CHAR(10)//CHAR(10)//' ')
	ENDIF

C	Check for contact with an alien.
 	DO 10 I=1,55
	IF ((ALIEN_ROW(I).EQ.BEAM_ROW).AND.((ALIEN_COL(I)+1).LE.BEAM_COL)
	1	    .AND.((ALIEN_COL(I)+3).GE.BEAM_COL)) THEN
C	Contact!
		SCORES = SCORES+(I/22)+1	!Add points.
		CALL MOVE(0,7)
		CALL SEND_INT(SCORES)
		CALL SEND(CHAR(7))	!Ring the bell.
		CALL MOVE(BEAM_ROW+1,BEAM_COL)
		CALL SEND(' ')
		CALL MOVE(ALIEN_ROW(I),ALIEN_COL(I))
		CALL DS_OBJ(6)		!Erase beam and alien.
		BEAM_ROW=0
		ALIEN_ROW(I)=0		!Clear beam and alien state.
		ALIENS_LEFT=ALIENS_LEFT-1
		RETURN
		ENDIF
10	CONTINUE

C	Check for contact with a bomb.
	DO 20 I=1,MAX_BOMBS
	IF (BEAM_COL.NE.BOMB_COL(I).OR.BOMB_ROW(I).EQ.0)GO TO 20
	IF(BEAM_ROW.EQ.BOMB_ROW(I).OR.BEAM_ROW-1.EQ.BOMB_ROW(I)) THEN
		CALL MOVE(BEAM_ROW,BEAM_COL)
		CALL SEND(' '//CHAR(8)//CHAR(10)//' ')
		BEAM_ROW = 0
		CALL MOVE(BOMB_ROW(I),BEAM_COL)
		CALL SEND(' '//CHAR(7))
		FALLING_BOMBS=FALLING_BOMBS-1
		BOMB_ROW(I) = 0
		RETURN
		ENDIF
20	CONTINUE

C	Check for contact with a barricade.
	IF ((BEAM_ROW.GE.19).AND.(BEAM_ROW.LE.22).AND.
	1(BARR(BEAM_ROW-18)(BEAM_COL+1:BEAM_COL+1).NE.' ')) THEN
		CALL MOVE(BEAM_ROW,BEAM_COL)
		CALL SEND(' '//CHAR(8)//CHAR(10)//' '//CHAR(7))
		BARR(BEAM_ROW-18)(BEAM_COL+1:BEAM_COL+1) = ' '
		BEAM_ROW = 0
		RETURN
		ENDIF

C	Check for contact with a mystery ship.
	I=SHIP_COL-SHIP_VEL
	IF (SHIP_VEL.NE.0.AND.BEAM_ROW.EQ.1.AND.BEAM_COL.GT.I
	1.AND.BEAM_COL.LT.I+7) THEN
C	Contact!
		CALL MOVE(1,I)
		CALL SEND(CHAR(7)//'        ')	!Erase ship.
		SHIP_VEL = 0
		SCORES = SCORES+SHIP_VAL/3
		CALL MOVE(0,7)
		CALL SEND_INT(SCORES)
	ENDIF
	RETURN
	END


	SUBROUTINE BOMB
C	Advance the next active bomb.
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL

	IF (FALLING_BOMBS.EQ.0)   RETURN
10	B=B+1
	IF (B.GT.MAX_BOMBS) B=1
	IF (BOMB_ROW(B).EQ.0) GO TO 10

C	Advance the bomb, check for hit, and display.
	BOMB_ROW(B)=BOMB_ROW(B)+1
	IF (BOMB_ROW(B).EQ.23) THEN
		IF ((BOMB_COL(B).GT.BASE_COL).AND.
	1	    (BOMB_COL(B).LE.(BASE_COL+5))) THEN
C	The base is hit!
			BASES=BASES-1
			CALL MOVE(0,77)
			CALL SEND_INT(BASES)
C	Make some noise, erase the base.
			CALL SEND(CHAR(7)//CHAR(7)//CHAR(7))
			IF (BASES.EQ.0) CALL HALT
			CALL SLEEP('02.00')	!Use all five characters.
			CALL MOVE(23,BASE_COL)
			CALL SEND('       ')
			BASE_COL = 72
			BASE_VEL = -1
			ENDIF		!Bomb erased below.
		ENDIF

	IF((BOMB_ROW(B).GE.19).AND.(BOMB_ROW(B).LT.23).AND.
	1(BARR(BOMB_ROW(B)-18)(BOMB_COL(B)+1:BOMB_COL(B)+1).NE.' ')) THEN
C	The bomb has hit a barricade.
		CALL MOVE(BOMB_ROW(B)-1,BOMB_COL(B))
		CALL SEND(' '//CHAR(8)//CHAR(10)//' '//CHAR(7))
		BARR(BOMB_ROW(B)-18)(BOMB_COL(B)+1:BOMB_COL(B)+1) = ' '
		BOMB_ROW(B) = 0
		FALLING_BOMBS=FALLING_BOMBS-1
		RETURN
		ENDIF

C	Now display bomb in its new location.
	CALL MOVE(BOMB_ROW(B)-1,BOMB_COL(B))
	CALL SEND(' '//CHAR(8)//CHAR(10)//'*')
	IF (BOMB_ROW(B).EQ.23) THEN	!Erase bomb.
		FALLING_BOMBS=FALLING_BOMBS-1
		BOMB_ROW(B) = 0
		CALL SEND(CHAR(8)//' ')
		ENDIF
	RETURN
	END


	SUBROUTINE SHIP
C	Create or advance a mystery ship (maybe).
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL
	REAL RAN
	INTEGER*4 SEED
	DATA SEED/337733893/

	IF (SHIP_VEL.EQ.0) THEN
		IF (RAN(SEED).LT..005) THEN
C	Create a mystery ship about once every minute.
			IF (RAN(SEED).LT..2) THEN
				SHIP_VEL = -1
				SHIP_COL = 72
			ELSE
				SHIP_VEL = 1
				SHIP_COL = 1
			ENDIF
			SHIP_VAL = 90
		ENDIF

	ELSE
C	Update an existing mystery ship.
		CALL MOVE(1,SHIP_COL)
		IF (GAME.NE.4) THEN
			WHIRL=MOD(SHIP_COL,3)
			IF(WHIRL.EQ.0)THEN
				CALL SEND(' <--`> ')
			ELSE IF (WHIRL.EQ.1)THEN
				CALL SEND(' <-`-> ')
			ELSE
				CALL SEND(' <`--> ')
				ENDIF
			ENDIF
		SHIP_VAL=SHIP_VAL-1
		SHIP_COL = SHIP_COL+SHIP_VEL
		IF (SHIP_COL.GT.72.OR.SHIP_COL.LT.1)THEN
C		Remove the mystery ship.
			CALL MOVE(1,SHIP_COL-SHIP_VEL)
			CALL SEND('        ')
			SHIP_VEL = 0
		ENDIF
	ENDIF
	RETURN
	END


	SUBROUTINE ADVANCE
C	Advance the next alien.
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL

10	ALIEN=ALIEN+1
	IF (ALIEN .GT. 55)THEN
		IF (ALIENS_LEFT.EQ.0)   RETURN ! check if done !
		FLOP = .FALSE.
		IF (FLIP) THEN 
			LEFT = .NOT.LEFT
			FLOP = .TRUE.
			ENDIF
		FLIP = .FALSE.
		ALIEN = 1
		ENDIF
	I=ALIEN_ROW(ALIEN)
	IF(I.LE.0)GO TO 10

	IF (I.GE.23) CALL HALT		!Aliens have overrun base.
	IF (LEFT) THEN
		ALIEN_COL(ALIEN)=ALIEN_COL(ALIEN)-1
	ELSE
		ALIEN_COL(ALIEN)=ALIEN_COL(ALIEN)+1
		ENDIF
	J=ALIEN_COL(ALIEN)
	IF (J.EQ.0.OR.J.EQ.75)   FLIP = .TRUE.
	CALL MOVE(I,J)
	IF (FLOP) THEN
		CALL DS_OBJ(6)
		ALIEN_ROW(ALIEN)=ALIEN_ROW(ALIEN)+1
		I=ALIEN_ROW(ALIEN)
		CALL MOVE(I,J)
		ENDIF
	CALL DS_OBJ((ALIEN.AND.1)+2*((ALIEN-1)/22))

C	Check for bomb release.
	IF ((GAME.EQ.1).OR.(GAME.EQ.2)) RETURN	!Disable bombs.
	DO 50 I=ALIEN-11,0,-11	!Don't drop bombs on your own men.
		IF (ALIEN_ROW(I).NE.0) RETURN
50		CONTINUE
	IF (ALIEN_COL(ALIEN).GE.BASE_COL.AND.ALIEN_COL(ALIEN).LT.BASE_COL+3
	1.AND.ALIEN_ROW(ALIEN).LE.MAX_BOMB_ROW) THEN
		DO 60 I=1,MAX_BOMBS
		IF (BOMB_ROW(I).EQ.0) THEN
			BOMB_ROW(I) = ALIEN_ROW(ALIEN)
			BOMB_COL(I) = ALIEN_COL(ALIEN) + 2
			FALLING_BOMBS=FALLING_BOMBS+1
			RETURN
			ENDIF
60		CONTINUE
	ENDIF
	RETURN
	END


	SUBROUTINE HALT
C	Game over processing.
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL

C	Display the aliens if they were invisible.
	IF (GAME.EQ.4) THEN
		GAME = 3	!Remove the cloak of invisibility.
		DO 10 I=1,55
		IF (ALIEN_ROW(I).NE.0) THEN
			CALL MOVE(ALIEN_ROW(I),ALIEN_COL(I))
			CALL DS_OBJ((I.AND.1)+2*(I/22))
			ENDIF
10		CONTINUE
		ENDIF

	DO 20 I=1,10
20	CALL SEND(CHAR(7))
	CALL SLEEP('05.00')	!Use all five characters.
	CALL SPECIAL_GRAPHIC(.FALSE.)
	CALL MOVE(23,0)
	CALL EXIT
	END


	SUBROUTINE SPECIAL_GRAPHIC(ON_OFF)
	LOGICAL ON_OFF
	BYTE TYP
	INTEGER*4 FLAG,RET_STAT

	RET_STAT=LIB$SCREEN_INFO(FLAG,TYP,,)
	IF(ON_OFF)THEN			!Turn on special graphics mode.
		IF(TYP.EQ.64)THEN	!We're in VT52 mode.
			CALL SEND(CHAR(27)//'F')
		ELSE IF(TYP.EQ.96.OR.TYP.EQ.110)THEN	!We're in VT100/200 mode
.
			TYPE*
			TYPE*,'I run faster in VT52 mode.  To set, type'
			TYPE*,'SET TERM/VT52	(and that''s all)'
			TYPE*,'from DCL level.  Otherwise, wait a moment.'
			TYPE*
			CALL SLEEP('10.00')	!Use all five characters.
			CALL SEND(CHAR(27)//'(0')
		ELSE			!We're on an unknown terminal.
			TYPE*,'Terminal type',TYP
			STOP'I only know how to address VT100''s and VT52''s.'
			ENDIF
	ELSE				!Reset to ASCII mode.
		IF(TYP.EQ.64)THEN	!Reset the VT52.
			CALL SEND(CHAR(27)//'G')
		ELSE			!Reset the VT100.
			CALL SEND(CHAR(27)//'(B')
			ENDIF
		ENDIF
	RETURN
	END


	SUBROUTINE MOVE(ROW,COL)
C	Position cursor to ROW,COL.
C	Row 0 is top of screen.  Row 23 is bottom-of-screen.
C	The leftmost column is 0.  The rightmost is 79.
	INTEGER*2 ROW,COL
	IDUMMY=SCR$SET_CURSOR(%VAL(ROW+1),%VAL(COL+1))
	RETURN
	END



	SUBROUTINE CLEAR
C	Clear screen.
	I=1
	I=LIB$ERASE_PAGE(I,I)
	RETURN
	END


	SUBROUTINE DS_OBJ(CLASS)
C	Display object of type CLASS at current screen position.
	IMPLICIT INTEGER*2 (A-Z)
	LOGICAL FLIP,FLOP,LEFT,SLOW
	CHARACTER*80 BARR
	COMMON/CHRS/BARR(4)
	PARAMETER MAX_BOMBS=4
	COMMON/DARTH/MAX_BOMB_ROW,SCORES,BASES,GAME
	1 ,DANGER,MAX_DANGER,FLIP,FLOP,LEFT,ALIEN,B,ALIENS_LEFT
	2 ,FALLING_BOMBS,SLOW
	3 ,ALIEN_ROW(55),ALIEN_COL(55),BASE_ROW,BASE_COL
	4 ,BASE_VEL,BEAM_ROW,BEAM_COL,BOMB_ROW(MAX_BOMBS),BOMB_COL(MAX_BOMBS)
	5 ,SHIP_VAL,SHIP_COL,SHIP_VEL
	INTEGER CLASS
	IF ((GAME.EQ.4).AND.(CLASS.GE.0).AND.(CLASS.LE.5))   CLASS = 6
	GO TO (1,2,3,4,5,6,7,8)CLASS+1
1	CALL SEND(' -`- ')
	RETURN
2	CALL SEND(' <`> ')
	RETURN
3	CALL SEND(' >`< ')
	RETURN
4	CALL SEND(' ``` ')
	RETURN
5	CALL SEND(' >a< ')
	RETURN
6	CALL SEND(' <x> ')
	RETURN
7	CALL SEND('     ')
	RETURN
8	CALL SEND(' lwnwk ')
	RETURN
	END


	SUBROUTINE SEND(CHARS)
C	Type CHARS to screen with no <CR> or <LF>'s.
	CHARACTER*(*) CHARS
	INTEGER*2 I

	TYPE 1,CHARS
1	FORMAT('+',A,$)
	RETURN

	ENTRY SEND_INT(I)
	TYPE 2,I
2	FORMAT('+',I4,$)
	RETURN
	END

User avatar

arne_v
Master
Posts: 308
Joined: Fri Apr 17, 2020 7:31 pm
Reputation: 0
Location: Rhode Island, USA
Status: Offline
Contact:

Re: Fortran JIOR

Post by arne_v » Thu May 11, 2023 4:15 pm

Yes - the problems must be the %LOC.

Code: Select all

	TIMED_IO = IOR(%LOC(IO$_READLBLK),%LOC(IO$M_TIMED))
	TIMED_IO = IOR(TIMED_IO,%LOC(IO$M_NOECHO))
...
1	SSCODE=SYS$QIOW(%VAL(0),%VAL(TT_CHAN),%VAL(TIMED_IO)
	1 ,TTIOSB,,,INCHAR,%VAL(1),%VAL(0),,,)
->

Code: Select all

	TIMED_IO = IOR(IO$_READLBLK,IO$M_TIMED)
	TIMED_IO = IOR(TIMED_IO,IO$M_NOECHO)
...
1	SSCODE=SYS$QIOW(%VAL(0),%VAL(TT_CHAN),%VAL(TIMED_IO)
	1 ,TTIOSB,,,INCHAR,%VAL(1),%VAL(0),,,)
Arne
arne@vajhoej.dk
VMS user since 1986


elementyl
Newbie
Posts: 4
Joined: Wed May 10, 2023 10:44 pm
Reputation: 0
Status: Offline

Re: Fortran JIOR

Post by elementyl » Fri May 12, 2023 3:33 am

afassl wrote:
Thu May 11, 2023 8:46 am

Code: Select all

			Video Terminal Space Invaders
C
C	Originally written in C by Jude Miller, 1979, Cambridge.
C	Translated to FORTRAN-77 by Jonathan Boswell, July '81
C	at the University of Virginia, Charlottesville, Virginia.
C
C	Machine dependent subroutines are SLEEP, CLEAR, MOVE, SPECIAL_GRAPHIC,
C	and FUNCTION INCHAR.  These subroutines are written for a VAX/VMS
C	operating system employing VT100 terminals.
C
	PROGRAM INVADERS
	[...]
The %LOC() are actually ok as they are being pulled in by the linker. If the timing is off (too fast?) perhaps the system you are running it on is a mite faster than the original. Runs fine for me.

User avatar

arne_v
Master
Posts: 308
Joined: Fri Apr 17, 2020 7:31 pm
Reputation: 0
Location: Rhode Island, USA
Status: Offline
Contact:

Re: Fortran JIOR

Post by arne_v » Fri May 12, 2023 8:54 pm

Ah EXTERNAL not include of $iodef. Then %LOC works even though it is a weird construct.

Code: Select all

      program symfun
      call var1
      call var2
      call var3
      end
c
      subroutine var1
      include '($iodef)'
      write(*,*) IO$_READLBLK
      write(*,*) IO$M_TIMED
      write(*,*) IO$M_NOECHO
      return
      end
c
      subroutine var2
      include '($iodef)'
      write(*,*) %loc(IO$_READLBLK)
      write(*,*) %loc(IO$M_TIMED)
      write(*,*) %loc(IO$M_NOECHO)
      return
      end
c
      subroutine var3
      external IO$_READLBLK, IO$M_TIMED, IO$M_NOECHO
      write(*,*) %loc(IO$_READLBLK)
      write(*,*) %loc(IO$M_TIMED)
      write(*,*) %loc(IO$M_NOECHO)
      return
      end
Arne
arne@vajhoej.dk
VMS user since 1986


elementyl
Newbie
Posts: 4
Joined: Wed May 10, 2023 10:44 pm
Reputation: 0
Status: Offline

Re: Fortran JIOR

Post by elementyl » Sat May 13, 2023 2:58 am

arne_v wrote:
Fri May 12, 2023 8:54 pm
Ah EXTERNAL not include of $iodef. Then %LOC works even though it is a weird construct.
I was thinking as you were until the code was provided. Back in the day this is how it was done when the system service include files were lacking for FORTRAN. Probably the first thing I would do if cleaning up that code would be to eliminate these for readability, but nice to see this code can still run with minimal changes.
putty_UgDBQD9TMf.gif

Post Reply