home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.update.uu.se
/
ftp.update.uu.se.2014.03.zip
/
ftp.update.uu.se
/
pub
/
rainbow
/
msdos
/
decus
/
RB117
/
chars.for
next >
Wrap
Text File
|
1995-05-28
|
9KB
|
453 lines
C
$STORAGE:2
C
C
C *******************************************************
C * *
C * The following Subroutines are used for cursor *
C * control and special effects on the SCREEN ONLY *
C * *
C *******************************************************
C
C
C
SUBROUTINE CURUP(INUM)
C
C This routine will move the CURSOR up
C
INTEGER INUM
IF(INUM.GT.0) THEN
DO 50 K=1,INUM
WRITE(*,'(1X,A1,A2,\)') 155,'1A'
WRITE(*,'(1X,A1,A2,\)') 155,'2K'
50 CONTINUE
WRITE(*,'(1X,A1,A2,\)') 155,'5D'
ENDIF
RETURN
END
C
C
C
SUBROUTINE CURDN(INUM)
C
C This routine will move the CURSOR down
C
INTEGER INUM
IF(INUM.GT.0) THEN
DO 50 K=1,INUM
WRITE(*,'(1X,A1,A2,\)') 155,'1B'
WRITE(*,'(1X,A1,A2,\)') 155,'2K'
50 CONTINUE
WRITE(*,'(1X,A1,A2,\)') 155,'5D'
ENDIF
RETURN
END
C
C
C
SUBROUTINE CURRT(INUM)
C
C This routine moves the CURSOR right
C
INTEGER INUM
IF(INUM.GT.0) THEN
WRITE(*,'(1X,A1,I2.2,A1,\)') 155,INUM,'C'
ENDIF
RETURN
END
C
C
C
SUBROUTINE CURLT(INUM)
C
C This routine moves the CURSOR left
C
INTEGER INUM
IF(INUM.GT.0) THEN
WRITE(*,'(1X,A1,I2.2,A1,\)') 155,INUM,'D'
ENDIF
RETURN
END
C
C
C
SUBROUTINE LOCATE(HORZ,VERT,RELOC)
CC
CC Author: Bruce W. Roeckel
CC Date: December 1986
CC
CC Description: This routine creates an escape sequence that will move
CC the cursor to a specific position on the screen. You must
CC write the sequence to the screen, followed by your data.
CC
CC Example: I want to position TEST on line 10, Col 40
CC
CC CHARACTER RELOC*11
CC
CC CALL LOCATE(40,10,RELOC)
CC WRITE(*,100) RELOC,'TEST'
CC 100 FORMAT(A11,A4)
CC
CC
CC
CC Update # Name Date Comments
CC -------- --------- -------- ----------------------------------
CC 001 Roeckel 01-07-87 Moved into System Library
CC
CC
INTEGER HORZ,VERT
CHARACTER RELOC*11
IF((HORZ.GT.0) .AND. (HORZ.LT.133)) THEN
IF((VERT.GT.0) .AND. (VERT.LT.25)) THEN
WRITE(RELOC,100) 27,'[',VERT,';',HORZ,'H'
100 FORMAT(1X,A1,A1,I3.3,A1,I3.3,A1)
ENDIF
ENDIF
RETURN
END
C
C
C
SUBROUTINE MOVEIT(HORZ,VERT)
C
C This routine moves the CURSOR anywere on the screen
C and clears the screen from that point down
C
INTEGER HORZ,VERT
IF((HORZ.GT.0) .AND. (HORZ.LT.133)) THEN
IF((VERT.GT.0) .AND. (VERT.LT.25)) THEN
WRITE(*,'(1X,A1,I3.3,A1,I3.3,A1,\)') 155,VERT,';',HORZ,'H'
WRITE(*,'(1X,A1,A1,\)') 155,'J'
WRITE(*,'(1X,A1,A2,\)') 155,'3D'
ENDIF
ENDIF
RETURN
END
C
C
C
SUBROUTINE UPTOP(HORZ,VERT)
C
C This routine moves the CURSOR anywere on the screen
C without clearing data on the screen
C
INTEGER HORZ,VERT,HOR2
HOR2=HORZ-2
IF(HOR2.LT.1) HOR2=1
IF((HOR2.GT.0) .AND. (HOR2.LT.133)) THEN
IF((VERT.GT.0) .AND. (VERT.LT.25)) THEN
WRITE(*,'(1X,A1,I3.3,A1,I3.3,A1,\)') 155,VERT,';',HOR2,'H'
ENDIF
ENDIF
RETURN
END
C
C
C
SUBROUTINE BELL
C
C This routine will ring the BELL on the Keyboard
C
WRITE(*,'(1X,A1,\)') 7
RETURN
END
C
C
C
SUBROUTINE DHTOP
C
C This routine is part 1 of DOUBLE HEIGHT, DOUBLE WIDE
C
WRITE(*,'(1X,A1,A2,\)') 27,'#3'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C
SUBROUTINE DHBOT
C
C This routine is part 2 of DOUBLE HEIGHT, DOUBLE WIDE
C
WRITE(*,'(1X,A1,A2,\)') 27,'#4'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C
SUBROUTINE HOME
C
C This routine sends the cursor to the HOME position
C
WRITE(*,'(1X,A1,A1,\)') 155,'H'
RETURN
END
C
C
C
SUBROUTINE CLS
C
C This routine clears from the top of the screen
C
WRITE(*,'(1X,A1,A1,\)') 155,'H'
WRITE(*,'(1X,A1,A2,\)') 155,'2J'
RETURN
END
C
C
C
SUBROUTINE BOLD
C
C This routine will BOLD all letters
C
WRITE(*,'(1X,A1,A2,\)') 155,'1m'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C
SUBROUTINE OFF
C
C This routine turns off all screen attributes
C
WRITE(*,'(1X,A1,A2,\)') 155,'0m'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C
SUBROUTINE ULINE
C
C This routine will start UNDERLINE feature
C
WRITE(*,'(1X,A1,A2,\)') 155,'4m'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C
SUBROUTINE HLIGHT(ILEN)
C
C This routine will highlight input areas
C
CALL RVIDEO
DO 100 I=1,ILEN
WRITE(*,'(1X,\)')
100 CONTINUE
CALL OFF
ILEN=ILEN+1
CALL CURLT(ILEN)
RETURN
END
C
C
C
SUBROUTINE BLINK
C
C This routine will invoke BLINKING of all characters
C
WRITE(*,'(1X,A1,A2,\)') 155,'5m'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C
SUBROUTINE RVIDEO
C
C This routine will REVERSE VIDEO all characters
C
WRITE(*,'(1X,A1,A2,\)') 155,'7m'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C
SUBROUTINE COL132
C
C This routine selects 132 COL display
C
WRITE(*,'(1X,A1,A3,\)') 155,'?3h'
WRITE(*,'(1X,A1,A2,\)') 155,'3D'
RETURN
END
C
C
C
SUBROUTINE COL080
C
C Thsi routine selects 80 COL display
C
WRITE(*,'(1X,A1,A3,\)') 155,'?3l'
WRITE(*,'(1X,A1,A2,\)') 155,'3D'
RETURN
END
C
C
C
SUBROUTINE KEYOFF
C
C This routine locks the KEYBOARD
C
WRITE(*,'(1X,A1,A2,\)') 155,'2h'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C
SUBROUTINE KEYON
C
C This routine resets the KEYBOARD
C
WRITE(*,'(1X,A1,A2,\)') 155,'2l'
WRITE(*,'(1X,A1,A2,\)') 155,'2D'
RETURN
END
C
C
C *******************************************************
C * *
C * The following Subroutines are used for the *
C * special VT100 Graphic Character set *
C * *
C *******************************************************
C
C
C
SUBROUTINE GCHAR(UNIT)
C
C This routine will select the VT100 Graphics Character set
C as G1. Use the 'SI' <cntl/O> command to make it the active
C character set, and the 'SO' <cntl/N> command to bring back
C the ASCII character set as the active one.
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A2,\)') 27,')0'
RETURN
END
C
C
C
SUBROUTINE GPHON(UNIT)
C
C This routine will activate the Graphics character set
C (This is the 'SI' <cntl/O> command)
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,\)') 14
RETURN
END
C
C
C
SUBROUTINE GPHOFF(UNIT)
C
C This routine will deactivate the Graphics character set
C (This is the 'SO' <cntl/N> command)
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,\)') 15
RETURN
END
C
C
C *******************************************************
C * *
C * The following Subroutines are used for special *
C * effects on the LA-50 printer *
C * *
C *******************************************************
C
C
SUBROUTINE PBOLD(UNIT)
C
C This routine starts BOLD printing
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A2,\)') 155,'1m'
RETURN
END
C
C
C
SUBROUTINE PULINE(UNIT)
C
C This routine selects UNDERLINED print
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A2,\)') 155,'4m'
RETURN
END
C
C
C
SUBROUTINE POFF(UNIT)
C
C This routine turns off BOTH Bold & Underline printing
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A2,\)') 155,'0m'
RETURN
END
C
C
C
SUBROUTINE DWIDTH(UNIT)
C
C This routine select DOUBLE-WIDTH print
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A2,\)') 155,'5w'
RETURN
END
C
C
C
SUBROUTINE SWIDTH(UNIT)
C
C This routine selects STANDARD-WIDTH print
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A2,\)') 155,'0w'
RETURN
END
C
C
C
SUBROUTINE WWIDTH(UNIT)
C
C This routine selects 132 Column printing
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A2,\)') 155,'4w'
RETURN
END
C
C
C
SUBROUTINE LQPON(UNIT)
C
C This routine selects LETTER QUALITY print
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A3,\)') 155,'2"z'
RETURN
END
C
C
C
SUBROUTINE LQPOFF(UNIT)
C
C This routine selects NORMAL print
C
INTEGER UNIT
WRITE(UNIT,'(1X,A1,A3,\)') 155,'0"z'
RETURN
END