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 / stdhead.for < prev    next >
Text File  |  1995-05-28  |  5KB  |  218 lines
  1. C
  2. $STORAGE:2
  3. C
  4. C
  5. C        *******************************************************
  6. C        *                                                     *
  7. C        *   The following Subroutines are used for the        *
  8. C        *   Standard Headers for all ROCKSOFT programs        *
  9. C        *                                                     *
  10. C        *******************************************************
  11. C
  12. C
  13.       SUBROUTINE MHEAD(PGM,AUTHOR,YEAR,REV,DATE)
  14. C
  15. C          This routine prints the copyright header
  16. C
  17.       IMPLICIT INTEGER (A-Z)
  18.       CHARACTER PGM*21,AUTHOR*21,TITLE*40,RELOC*11
  19.       CHARACTER RAMDSK*80,TYPE*6,ONE*1,TWO*1,DATE*8,REV*2,YEAR*4
  20.       LOGICAL*2 CHECK
  21. C
  22. C          DRAW TWO BOXES ON SCREEN         
  23. C
  24.       HEIGHT=5
  25.       WIDTH=80
  26.       HORZ=1
  27.       VERT=2
  28.       TITLE=' '
  29.       TLEN=0
  30.       TATTR=0
  31.       BATTR=0
  32.          CALL CLS
  33.          CALL BOLD
  34.          CALL BOX(HEIGHT,WIDTH,HORZ,VERT,TITLE,TLEN,TATTR,BATTR)
  35.       VERT=16 
  36.       HEIGHT=8
  37.          CALL BOLD
  38.          CALL BOX(HEIGHT,WIDTH,HORZ,VERT,TITLE,TLEN,TATTR,BATTR)
  39. C
  40. C          NOW, START OUT WITH THE MAJOR HEADING
  41. C
  42.       CALL UPTOP(4,4)
  43.       WRITE(*,'(23X,A28,\)') 'DEC Rainbow 100 Software by:'
  44. C
  45. C          SECOND, DRAW THE ROCKSOFT LOGO
  46. C
  47.       CALL UPTOP(4,10)
  48.       CALL BOLD
  49.       CALL DHTOP
  50.          WRITE(*,100)
  51.   100    FORMAT(12X,'* ROCKSOFT *',\)
  52.       CALL UPTOP(4,11)
  53.       CALL BOLD
  54.       CALL DHBOT
  55.          WRITE(*,100)
  56.       CALL OFF
  57. C
  58. C           NOW PRINT OTHER ASSORTED GOODIES
  59. C
  60.       CALL UPTOP(4,13)
  61.          WRITE(*,'(28X,A13,A4,\)') 'Copyright (c)',YEAR
  62. C
  63.       WRITE(RAMDSK,'(A21,A7,A2)') PGM,', Ver. ',REV  
  64.       CALL SQUISH(RAMDSK,30)
  65.       TYPE='LEFT  '
  66.       CALL JUSTIF(TYPE,RAMDSK,30)
  67.       CALL UPTOP(4,18)
  68.       CALL BOLD
  69.          WRITE(*,'(9X,A9,\)') 'Program: '
  70.       CALL OFF
  71.          WRITE(*,'(A30,\)') RAMDSK
  72. C
  73.       CALL UPTOP(4,19)
  74.       CALL BOLD
  75.          WRITE(*,'(9X,A9,\)') 'Author : '
  76.       CALL OFF
  77.          WRITE(*,'(A21,\)') AUTHOR   
  78. C
  79. C           CHECK FOR DATE FILE IN THE MEMORY DRIVE  
  80. C
  81.       CALL BLINK
  82.       CALL BOLD
  83.       INQUIRE(FILE='F:TODAY.DAT',EXIST=CHECK)
  84.       IF(CHECK.EQV..TRUE.) THEN     
  85.  
  86.          OPEN(UNIT=5,FILE='F:TODAY.DAT')
  87.          READ(5,'(A8)') DATE
  88.          CLOSE(5)
  89.          CALL UPTOP(4,21)
  90.          WRITE(*,200)
  91.   200    FORMAT(9X,'Please Press <RETURN> to Begin Execution ',\)
  92.          READ(*,'(A1)') ONE
  93.  
  94.       ELSE
  95.  
  96.   300    CONTINUE
  97.          CALL UPTOP(4,21)
  98.          WRITE(*,350)
  99.   350    FORMAT(9X,'Please Enter TODAY"S Date (MM/DD/YY): [  /  /  ]',\)
  100.          CALL CURLT(10)
  101.          READ(*,'(A8,\)',ERR=300) DATE
  102.          WRITE(RAMDSK,'(A8)') DATE
  103.          READ(RAMDSK,375,ERR=300) IMON,ONE,IDAY,TWO,IYEAR
  104.   375    FORMAT(I2,A1,I2,A1,I2)
  105. C
  106. C            CHECK IF DATE ENTERED MAKES SENSE
  107. C
  108.          IF((ONE.NE.'/') .OR. (TWO.NE.'/')  .OR.    
  109.      A      (IMON.LE.0) .OR. (IMON.GT.12)   .OR.   
  110.      B      (IDAY.LE.0) .OR. (IDAY.GT.32)   .OR.   
  111.      C      (IYEAR.LE.80) .OR. (IYEAR.GT.99)) THEN    
  112.             CALL UPTOP (4,22)
  113.             WRITE(*,'(9X,A32,\)') 'Invalid DATE Entered - Try Again'
  114.             CALL BELL
  115.             GOTO 300
  116.          ENDIF
  117.  
  118.       ENDIF
  119. C
  120. C            THATS ALL FOR NOW FOLKS
  121. C
  122.   900 CONTINUE
  123.       CALL OFF
  124.       CALL CLS
  125.       RETURN
  126.       END
  127. C
  128. C
  129. C
  130.       SUBROUTINE TOP(PGM,DATE)
  131. C
  132. C          This Routine displays the STANDARD Screen Header
  133. C
  134.       CHARACTER PGM*21,DATE*8,TODAY*28,RELOC*11
  135. C
  136. C          CONVERT DATE, THEN PRINT HEADER
  137. C
  138.       CALL CLS
  139.       CALL DATETD(DATE,TODAY)
  140.       CALL BOLD
  141.       CALL DHTOP
  142.       CALL LOCATE(1,1,RELOC)
  143.          WRITE(*,'(A11,A21)') RELOC,PGM
  144.       CALL DHBOT
  145.       CALL LOCATE(1,2,RELOC)
  146.          WRITE(*,'(A11,A21)') RELOC,PGM
  147.       CALL OFF
  148. C
  149. C        PRINT TODAYS DATE
  150. C
  151.       CALL LOCATE(53,3,RELOC)
  152.       WRITE(*,'(A11,A28)') RELOC,TODAY
  153. C
  154. C        DRAW A SOLID LINE
  155. C
  156.       CALL BOLD
  157.       CALL ULINE
  158.       CALL LOCATE(1,4,RELOC)
  159.          WRITE(*,'(A11,80X)') RELOC
  160.       CALL OFF
  161.       RETURN
  162.       END
  163. C
  164. C
  165. C
  166.       SUBROUTINE HEADER(OPTION)
  167. C
  168. C         This Routine Displays the OPTION under the Header (TOP)
  169. C
  170.       CHARACTER OPTION*25,RELOC*11
  171. C
  172.       CALL LOCATE(1,3,RELOC)
  173.          WRITE(*,'(A11,A9,\)') RELOC,'Option : '
  174.       CALL BOLD
  175.       CALL BLINK
  176.          WRITE(*,'(A25,\)') OPTION
  177.       CALL OFF
  178.       CALL MOVEIT(1,5)
  179.       RETURN
  180.       END
  181. C
  182. C
  183. C
  184.       SUBROUTINE PHEAD(PAGE,UNIT,PGM,DATE,YEAR,REV)
  185. C
  186. C          This Rouitne prints the STANDARD Printer Header
  187. C
  188.       INTEGER PAGE,UNIT
  189.       CHARACTER PGM*21,DATE*8,YEAR*4,REV*2
  190.       CHARACTER TYPE*6,STRING*80,TODAY*28
  191. C
  192. C          CONVERT DATE TO ALPHA, CENTER PROGRAM NAME
  193. C
  194.       CALL DATETD(DATE,TODAY)
  195.       TYPE='CENTER'
  196.       STRING=PGM
  197.       CALL JUSTIF(TYPE,STRING,21)
  198. C
  199. C          INCREMENT PAGE COUNTER, START DRAWING HEADER
  200. C
  201.       PAGE=PAGE+1
  202.       WRITE(UNIT,100) PAGE
  203.   100 FORMAT(1H1,/,2X,'DEC Rainbow 100 Software',45X,'Page ',I2)
  204.       WRITE(UNIT,200) REV,YEAR,TODAY
  205.   200 FORMAT(2X,'Ver. ',A2,', (c) ',A4,' by Rocksoft',19X,A28)
  206. C
  207. C          PRINT THE PROGRAM NAME FOR REFERENCE
  208. C
  209.       WRITE(UNIT,300)
  210.   300 FORMAT(1X,'*',76('-'),'*')
  211.       WRITE(UNIT,'(29X,A21)') STRING
  212.       WRITE(UNIT,300)
  213. C
  214. C          THAT ALL FOR NOW FOLKS
  215. C
  216.       RETURN
  217.       END
  218.