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 >
Text File  |  1995-05-28  |  9KB  |  453 lines
  1. C
  2. $STORAGE:2
  3. C
  4. C
  5. C        *******************************************************
  6. C        *                                                     *
  7. C        *   The following Subroutines are used for cursor     *
  8. C        *   control and special effects on the SCREEN ONLY    *
  9. C        *                                                     *
  10. C        *******************************************************
  11. C
  12. C
  13. C
  14.       SUBROUTINE CURUP(INUM)
  15. C
  16. C          This routine will move the CURSOR up
  17. C
  18.       INTEGER INUM
  19.       IF(INUM.GT.0) THEN
  20.       DO 50 K=1,INUM
  21.          WRITE(*,'(1X,A1,A2,\)') 155,'1A'
  22.          WRITE(*,'(1X,A1,A2,\)') 155,'2K'
  23.    50 CONTINUE
  24.       WRITE(*,'(1X,A1,A2,\)') 155,'5D'
  25.       ENDIF
  26.       RETURN
  27.       END
  28. C
  29. C
  30. C
  31.       SUBROUTINE CURDN(INUM)
  32. C
  33. C          This routine will move the CURSOR down
  34. C
  35.       INTEGER INUM
  36.       IF(INUM.GT.0) THEN
  37.       DO 50 K=1,INUM
  38.          WRITE(*,'(1X,A1,A2,\)') 155,'1B'
  39.          WRITE(*,'(1X,A1,A2,\)') 155,'2K'
  40.    50 CONTINUE
  41.       WRITE(*,'(1X,A1,A2,\)') 155,'5D'
  42.       ENDIF
  43.       RETURN
  44.       END
  45. C
  46. C
  47. C
  48.       SUBROUTINE CURRT(INUM)
  49. C
  50. C         This routine moves the CURSOR right
  51. C
  52.       INTEGER INUM
  53.       IF(INUM.GT.0) THEN
  54.          WRITE(*,'(1X,A1,I2.2,A1,\)') 155,INUM,'C'
  55.       ENDIF
  56.       RETURN
  57.       END
  58. C
  59. C
  60. C
  61.       SUBROUTINE CURLT(INUM)
  62. C
  63. C        This routine moves the CURSOR left
  64. C
  65.       INTEGER INUM
  66.       IF(INUM.GT.0) THEN
  67.          WRITE(*,'(1X,A1,I2.2,A1,\)') 155,INUM,'D'
  68.       ENDIF
  69.       RETURN
  70.       END
  71. C
  72. C
  73. C
  74.       SUBROUTINE LOCATE(HORZ,VERT,RELOC)
  75. CC
  76. CC         Author: Bruce W. Roeckel
  77. CC           Date: December 1986
  78. CC
  79. CC    Description: This routine creates an escape sequence that will move
  80. CC                 the cursor to a specific position on the screen. You must
  81. CC                 write the sequence to the screen, followed by your data.
  82. CC
  83. CC               Example: I want to position TEST on line 10, Col 40
  84. CC
  85. CC                        CHARACTER RELOC*11
  86. CC
  87. CC                        CALL LOCATE(40,10,RELOC)
  88. CC                        WRITE(*,100) RELOC,'TEST'
  89. CC                  100   FORMAT(A11,A4)
  90. CC
  91. CC
  92. CC
  93. CC    Update #    Name       Date          Comments
  94. CC    --------  ---------  --------  ----------------------------------
  95. CC       001    Roeckel    01-07-87  Moved into System Library
  96. CC
  97. CC
  98.       INTEGER HORZ,VERT
  99.       CHARACTER RELOC*11
  100.       IF((HORZ.GT.0) .AND. (HORZ.LT.133)) THEN
  101.          IF((VERT.GT.0) .AND. (VERT.LT.25)) THEN
  102.             WRITE(RELOC,100) 27,'[',VERT,';',HORZ,'H'
  103.   100       FORMAT(1X,A1,A1,I3.3,A1,I3.3,A1)
  104.          ENDIF
  105.       ENDIF
  106.       RETURN
  107.       END
  108. C
  109. C
  110. C
  111.       SUBROUTINE MOVEIT(HORZ,VERT)
  112. C
  113. C          This routine moves the CURSOR anywere on the screen
  114. C          and clears the screen from that point down
  115. C
  116.       INTEGER HORZ,VERT
  117.       IF((HORZ.GT.0) .AND. (HORZ.LT.133)) THEN
  118.          IF((VERT.GT.0) .AND. (VERT.LT.25)) THEN
  119.             WRITE(*,'(1X,A1,I3.3,A1,I3.3,A1,\)') 155,VERT,';',HORZ,'H'
  120.             WRITE(*,'(1X,A1,A1,\)') 155,'J'
  121.             WRITE(*,'(1X,A1,A2,\)') 155,'3D'
  122.          ENDIF
  123.       ENDIF
  124.       RETURN
  125.       END
  126. C
  127. C
  128. C
  129.       SUBROUTINE UPTOP(HORZ,VERT)
  130. C
  131. C          This routine moves the CURSOR anywere on the screen
  132. C          without clearing data on the screen         
  133. C
  134.       INTEGER HORZ,VERT,HOR2
  135.       HOR2=HORZ-2
  136.       IF(HOR2.LT.1) HOR2=1
  137.       IF((HOR2.GT.0) .AND. (HOR2.LT.133)) THEN
  138.          IF((VERT.GT.0) .AND. (VERT.LT.25)) THEN
  139.             WRITE(*,'(1X,A1,I3.3,A1,I3.3,A1,\)') 155,VERT,';',HOR2,'H'
  140.          ENDIF
  141.       ENDIF
  142.       RETURN
  143.       END
  144. C
  145. C
  146. C
  147.       SUBROUTINE BELL 
  148. C
  149. C         This routine will ring the BELL on the Keyboard     
  150. C
  151.       WRITE(*,'(1X,A1,\)') 7
  152.       RETURN
  153.       END
  154. C
  155. C
  156. C
  157.       SUBROUTINE DHTOP
  158. C
  159. C         This routine is part 1 of DOUBLE HEIGHT, DOUBLE WIDE
  160. C
  161.       WRITE(*,'(1X,A1,A2,\)') 27,'#3'
  162.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  163.       RETURN
  164.       END
  165. C
  166. C
  167. C
  168.       SUBROUTINE DHBOT
  169. C
  170. C         This routine is part 2 of DOUBLE HEIGHT, DOUBLE WIDE
  171. C
  172.       WRITE(*,'(1X,A1,A2,\)') 27,'#4'
  173.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  174.       RETURN
  175.       END
  176. C
  177. C
  178. C
  179.       SUBROUTINE HOME
  180. C
  181. C         This routine sends the cursor to the HOME position
  182. C
  183.       WRITE(*,'(1X,A1,A1,\)') 155,'H'
  184.       RETURN
  185.       END
  186. C
  187. C
  188. C
  189.       SUBROUTINE CLS
  190. C
  191. C          This routine clears from the top of the screen
  192. C
  193.       WRITE(*,'(1X,A1,A1,\)') 155,'H'
  194.       WRITE(*,'(1X,A1,A2,\)') 155,'2J'
  195.       RETURN
  196.       END
  197. C
  198. C
  199. C
  200.       SUBROUTINE BOLD
  201. C
  202. C          This routine will BOLD all letters
  203. C
  204.       WRITE(*,'(1X,A1,A2,\)') 155,'1m'
  205.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  206.       RETURN
  207.       END
  208. C
  209. C
  210. C
  211.       SUBROUTINE OFF
  212. C
  213. C          This routine turns off all screen attributes
  214. C
  215.       WRITE(*,'(1X,A1,A2,\)') 155,'0m'
  216.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  217.       RETURN
  218.       END
  219. C
  220. C
  221. C
  222.       SUBROUTINE ULINE
  223. C
  224. C          This routine will start UNDERLINE feature
  225. C
  226.       WRITE(*,'(1X,A1,A2,\)') 155,'4m'
  227.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  228.       RETURN
  229.       END
  230. C
  231. C
  232. C
  233.       SUBROUTINE HLIGHT(ILEN)
  234. C
  235. C         This routine will highlight input areas
  236. C
  237.       CALL RVIDEO
  238.          DO 100 I=1,ILEN
  239.          WRITE(*,'(1X,\)')
  240.   100    CONTINUE
  241.       CALL OFF
  242.          ILEN=ILEN+1
  243.          CALL CURLT(ILEN)
  244.       RETURN
  245.       END
  246. C
  247. C
  248. C
  249.       SUBROUTINE BLINK
  250. C
  251. C          This routine will invoke BLINKING of all characters
  252. C
  253.       WRITE(*,'(1X,A1,A2,\)') 155,'5m'
  254.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  255.       RETURN
  256.       END
  257. C
  258. C
  259. C
  260.       SUBROUTINE RVIDEO
  261. C
  262. C         This routine will REVERSE VIDEO all characters
  263. C
  264.       WRITE(*,'(1X,A1,A2,\)') 155,'7m'
  265.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  266.       RETURN
  267.       END
  268. C
  269. C
  270. C
  271.       SUBROUTINE COL132
  272. C
  273. C         This routine selects 132 COL display
  274. C
  275.       WRITE(*,'(1X,A1,A3,\)') 155,'?3h'
  276.       WRITE(*,'(1X,A1,A2,\)') 155,'3D'
  277.       RETURN
  278.       END
  279. C
  280. C
  281. C
  282.       SUBROUTINE COL080
  283. C
  284. C         Thsi routine selects 80 COL display
  285. C
  286.       WRITE(*,'(1X,A1,A3,\)') 155,'?3l'
  287.       WRITE(*,'(1X,A1,A2,\)') 155,'3D'
  288.       RETURN
  289.       END
  290. C
  291. C
  292. C
  293.       SUBROUTINE KEYOFF
  294. C
  295. C         This routine locks the KEYBOARD
  296. C
  297.       WRITE(*,'(1X,A1,A2,\)') 155,'2h'
  298.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  299.       RETURN
  300.       END
  301. C
  302. C
  303. C
  304.       SUBROUTINE KEYON
  305. C
  306. C         This routine resets the KEYBOARD
  307. C
  308.       WRITE(*,'(1X,A1,A2,\)') 155,'2l'
  309.       WRITE(*,'(1X,A1,A2,\)') 155,'2D'
  310.       RETURN
  311.       END
  312. C
  313. C
  314. C        *******************************************************
  315. C        *                                                     *
  316. C        *   The following Subroutines are used for the        *
  317. C        *   special VT100 Graphic Character set               *
  318. C        *                                                     *
  319. C        *******************************************************
  320. C
  321. C
  322. C
  323.       SUBROUTINE GCHAR(UNIT) 
  324. C
  325. C         This routine will select the VT100 Graphics Character set
  326. C         as G1. Use the 'SI' <cntl/O> command to make it the active
  327. C         character set, and the 'SO' <cntl/N> command to bring back 
  328. C         the ASCII character set as the active one.
  329. C
  330.       INTEGER UNIT
  331.       WRITE(UNIT,'(1X,A1,A2,\)') 27,')0'
  332.       RETURN
  333.       END
  334. C
  335. C
  336. C
  337.       SUBROUTINE GPHON(UNIT)
  338. C
  339. C         This routine will activate the Graphics character set
  340. C             (This is the 'SI' <cntl/O> command)
  341. C
  342.       INTEGER UNIT
  343.       WRITE(UNIT,'(1X,A1,\)') 14
  344.       RETURN
  345.       END
  346. C
  347. C
  348. C
  349.       SUBROUTINE GPHOFF(UNIT)
  350. C
  351. C         This routine will deactivate the Graphics character set
  352. C             (This is the 'SO' <cntl/N> command)
  353. C
  354.       INTEGER UNIT
  355.       WRITE(UNIT,'(1X,A1,\)') 15
  356.       RETURN
  357.       END
  358. C
  359. C
  360. C        *******************************************************
  361. C        *                                                     *
  362. C        *   The following Subroutines are used for special    *
  363. C        *   effects on the LA-50 printer                      *
  364. C        *                                                     *
  365. C        *******************************************************
  366. C
  367. C
  368.       SUBROUTINE PBOLD(UNIT)
  369. C
  370. C        This routine starts BOLD printing
  371. C
  372.       INTEGER UNIT
  373.       WRITE(UNIT,'(1X,A1,A2,\)') 155,'1m'
  374.       RETURN
  375.       END
  376. C
  377. C
  378. C
  379.       SUBROUTINE PULINE(UNIT)
  380. C
  381. C        This routine selects UNDERLINED print
  382. C
  383.       INTEGER UNIT
  384.       WRITE(UNIT,'(1X,A1,A2,\)') 155,'4m'
  385.       RETURN
  386.       END
  387. C
  388. C
  389. C
  390.       SUBROUTINE POFF(UNIT)
  391. C
  392. C        This routine turns off BOTH Bold & Underline printing
  393. C
  394.       INTEGER UNIT
  395.       WRITE(UNIT,'(1X,A1,A2,\)') 155,'0m'
  396.       RETURN
  397.       END
  398. C
  399. C
  400. C
  401.       SUBROUTINE DWIDTH(UNIT)
  402. C
  403. C        This routine select DOUBLE-WIDTH print
  404. C
  405.       INTEGER UNIT
  406.       WRITE(UNIT,'(1X,A1,A2,\)') 155,'5w'
  407.       RETURN
  408.       END
  409. C
  410. C
  411. C
  412.       SUBROUTINE SWIDTH(UNIT)
  413. C
  414. C       This routine selects STANDARD-WIDTH print
  415. C
  416.       INTEGER UNIT
  417.       WRITE(UNIT,'(1X,A1,A2,\)') 155,'0w'
  418.       RETURN
  419.       END
  420. C
  421. C
  422. C
  423.       SUBROUTINE WWIDTH(UNIT)
  424. C
  425. C       This routine selects 132 Column printing 
  426. C
  427.       INTEGER UNIT
  428.       WRITE(UNIT,'(1X,A1,A2,\)') 155,'4w'
  429.       RETURN
  430.       END
  431. C
  432. C
  433. C
  434.       SUBROUTINE LQPON(UNIT)
  435. C
  436. C        This routine selects LETTER QUALITY print
  437. C
  438.       INTEGER UNIT
  439.       WRITE(UNIT,'(1X,A1,A3,\)') 155,'2"z'
  440.       RETURN
  441.       END
  442. C
  443. C
  444. C
  445.       SUBROUTINE LQPOFF(UNIT)
  446. C
  447. C        This routine selects NORMAL print
  448. C
  449.       INTEGER UNIT
  450.       WRITE(UNIT,'(1X,A1,A3,\)') 155,'0"z'
  451.       RETURN
  452.       END
  453.