Retro1.org codex

User Tools

Site Tools

Trace: • PANEL
cdc:nos2.source:opl871:panel

Table of Contents

PANEL

Table Of Contents

Source Code

PANEL.txt 
  1. C------------------------------------------------------------------- 
  2. C*      PANEL DESIGN UTILITY
  3. C
  4. C         COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
  5. C
  6.         PROGRAM PANEL(PANEL=/266,OUTPUT=/266,TAPE1=PANEL)
  7. *CALL   COMFPAN
  8. C
  9. C       SCAN PARAMETERS
  10. C
  11.         CALL CSETA
  12.         CALL SPP
  13.         WRITE(2,'(A/)') '1 P^A^N^E^L D^E^F^I^N^I^T^I^O^N ' //
  14.      A                'U^T^I^L^I^T^Y         F^I^L^E ' // PNAME
  15. C
  16. C       SCAN PANEL DEFINITIONS
  17. C
  18.         CALL READL1
  19.         IF (ISA(IMAG(1,1))) THEN
  20.           CALL SCANSYM
  21. 1         IF (IMAG(SJ,1).EQ.ZSP.AND.SJ.LE.MCOL) THEN
  22.             SJ = SJ + 1
  23.             GOTO 1
  24.           ENDIF
  25.           IF (SJ.GT.MCOL) THEN
  26.             PNAME = STRGD(1:SL)
  27.             CALL READL1
  28.           ENDIF
  29.         ENDIF
  30. 2       IF (IMAG(SJ,1).EQ.ZSP.AND.SJ.LE.MCOL) THEN
  31.           SJ = SJ + 1
  32.           GOTO 2
  33.         ENDIF
  34.         IF (IMAG(SJ,1).EQ.ZLB) THEN
  35.           CLDC = ZRB
  36.         ELSE IF (IMAG(SJ,1).EQ.ZOB) THEN
  37.           CLDC = ZCB
  38.         ELSE IF (IMAG(SJ,1).EQ.ZLT) THEN
  39.           CLDC = ZGT
  40.         ELSE
  41.           CALL QUIT('OPENING DELIMITER.')
  42.         ENDIF
  43.         INDEF = .TRUE.
  44.         SJ = SJ + 1
  45.         CALL SCANDEF
  46.         INDEF = .FALSE.
  47.         IF (ABEND) CALL QUIT('DECLARATIONS')
  48. C
  49. C       SCAN PANEL IMAGE
  50. C
  51.         CALL RPI
  52.         CALL SCANIMG
  53.         IF (FATAL) CALL QUIT('SCREEN IMAGE')
  54. C
  55. C       WRITE PANEL DESCRIPTION
  56. C
  57.         IF (.NOT.FATAL) THEN
  58.           CALL GPR
  59.         ENDIF
  60.         REWIND 1
  61.         REWIND 2
  62.         REWIND 3
  63. C
  64.         END
  65. C-------------------------------------------------------------------
  66. C*      BLOCK DATA FOR PANEL
  67. C
  68.         BLOCK DATA
  69. *CALL   COMFPAN
  70.         DATA PNAME /'TEST   '/
  71.         DATA BLANK/' '/
  72.         DATA IMAG  /10304*0/, NROW /0/, NCOL/0/
  73.         DATA VERS,MSGL,MSGX,MSGY,CLDC/0,20,39,0,0/
  74.         DATA VERS,MSGL,MSGX,MSGY/1,20,39,0/
  75.         DATA BLKA,ERBW,ERAR,WRIB/0,1,0,0/
  76.         DATA FATAL /.FALSE./, INDEF /.FALSE./, ENDFILE /.FALSE./
  77.         DATA ABEND /.FALSE./
  78. C
  79. C       ATTRIBUTE DATA, LOGICAL FLAG, INPUT/OUTPUT, ORDINAL, NUMBER
  80. C
  81.         DATA ATRLP /'1','1','1',61*'0'/
  82.         DATA ATIO  /2,0,2,61*2/
  83.         DATA ATTP  /4,0,1,61*0/
  84.         DATA NATR  /3/
  85. C
  86. C       ATTRIBUTE DATA, ALTERNATE, BLINK, INVERSE AND UNDERLINE
  87. C
  88.         DATA ATRAI /MATR*'0'/
  89.         DATA ATRBL /MATR*'0'/
  90.         DATA ATRIV /MATR*'0'/
  91.         DATA ATRUL /MATR*'0'/
  92. C
  93. C       ATTRIBUTE DATA, BRACKET ID, CHAR. END, CHAR. START, LINE
  94. C                       WEIGHT AND SPECIAL CHARACTER
  95. C
  96.         DATA ATBI  /MATR*0/
  97.         DATA ATCE  /MATR*0/
  98.         DATA ATCS  /MATR*0/
  99.         DATA ATLW  /MATR*0/
  100.         DATA ATSC  /MATR*0/
  101.         DATA SPCH  /128*0/
  102. C
  103.         DATA NBOX  /0/
  104.         DATA IBOX  /0/
  105.         DATA CORS  /0/
  106. C       CORNER TYPES
  107. C
  108. C       D U R L         TYPE    ORDINAL
  109. C       0 0 0 0         CROSS   10
  110. C       0 0 0 1         HL      0
  111. C       0 0 1 0         HL      0
  112. C       0 0 1 1         HL      0
  113. C       0 1 0 0         VL      1
  114. C       0 1 0 1         LU      5
  115. C       0 1 1 0         UR      4
  116. C       0 1 1 1         LUR     7
  117. C       1 0 0 0         VL      1
  118. C       1 0 0 1         LD      3
  119. C       1 0 1 0         RD      2
  120. C       1 0 1 1         LRD(T)  6
  121. C       1 1 0 0         VL      1
  122. C       1 1 0 1         LUD     9
  123. C       1 1 1 0         URD     8
  124. C       1 1 1 1         CROSS   10
  125. C
  126.         DATA CORO/10,0,0,0,1,5,4,7,1,3,2,6,1,9,8,10/
  127. C
  128.         DATA NCON  /0/
  129. C
  130.         DATA NFIE  /0/
  131. C
  132.         DATA NFUN, FUNA, FUNG, FUNK  /0, MFUN*0, MFUN*0, MFUN*0/
  133. C
  134.         DATA SYMTP  /' '/
  135.         DATA STRGD  /' '/
  136.         DATA SI, SJ  /1,1/
  137.         DATA SL, STRG, SINT, SIGN  /0, MCOL*0, 0, 0/
  138.         DATA SREALV  /0.0/
  139. C
  140.         DATA TABNM  /8*'*'/
  141.         DATA NTAB   /0/
  142. C
  143.         DATA VARNM  /256*' '/
  144.         DATA TYPES  /'CHAR', 'INT', 'REAL'/
  145.         DATA NVAR  /0/
  146.         DATA NVAF  /0/
  147.         DATA VDCO  /0/
  148.         DATA NVAL  /0/
  149.       END
  150. C-------------------------------------------------------------------
  151. C*      BLOCK - GENERATE BLOCK COMMENTS
  152. C
  153.         SUBROUTINE BLOCK(S)
  154.         CHARACTER*(*) S
  155.         WRITE (3,100) S
  156. 100     FORMAT('*'/'*', T10, A/'*')
  157.         END
  158. C-------------------------------------------------------------------
  159. C*      BSS - BSS 0
  160. C
  161.         SUBROUTINE BSS
  162. *CALL   COMFPAN
  163.         WRITE(3,100)
  164. 100     FORMAT(T10,'BSS',T16,'0')
  165.         END
  166. C-------------------------------------------------------------------
  167. C*      CHEKATR - CHECK ATTRIBUTE
  168. C
  169. C       EXIT    LP= 1=LOGICAL, 0=PHYSICAL, 3=ERROR
  170. C               I = 0,1,2,... PARALLEL USE IN SETATR
  171. C
  172.         SUBROUTINE CHEKATR(LP,I)
  173. *CALL   COMFPAN
  174.         LP = 1
  175.         IF (UPSYMEQ('ITEXT').OR.UPSYMEQ('INPUT')) THEN
  176.           I = 0
  177.         ELSEIF (UPSYMEQ('TEXT')) THEN
  178.           I = 1
  179.         ELSEIF (UPSYMEQ('ITALIC')) THEN
  180.           I = 2
  181.         ELSEIF (UPSYMEQ('TITLE')) THEN
  182.           I = 3
  183.         ELSEIF (UPSYMEQ('MESSAGE')) THEN
  184.           I = 4
  185.         ELSEIF (UPSYMEQ('ERROR')) THEN
  186.           I = 5
  187.         ELSEIF (UPSYMEQ('ITEXT2').OR.UPSYMEQ('INPUT2')) THEN
  188.           I = 6
  189.         ELSEIF (UPSYMEQ('TEXT2')) THEN
  190.           I = 7
  191.         ELSEIF (UPSYMEQ('ITALIC2')) THEN
  192.           I = 8
  193.         ELSEIF (UPSYMEQ('TITLE2')) THEN
  194.           I = 9
  195.         ELSEIF (UPSYMEQ('MESSAGE2')) THEN
  196.           I = 10
  197.         ELSEIF (UPSYMEQ('ERROR2')) THEN
  198.           I = 11
  199.         ELSE
  200.           LP = 0
  201.           IF (UPSYMEQ('BLINK')) THEN
  202.             I = 6
  203.           ELSEIF (UPSYMEQ('INVERSE').OR.UPSYMEQ('INV')) THEN
  204.             I = 7
  205.           ELSEIF (UPSYMEQ('UNDERLINE').OR.UPSYMEQ('UND')
  206.      A            .OR.UPSYMEQ('UNDERSCORE')) THEN
  207.             I = 8
  208.           ELSEIF (UPSYMEQ('ALTERNATE').OR.UPSYMEQ('ALT')) THEN
  209.             I = 9
  210.           ELSE
  211.             LP = 3
  212.           ENDIF
  213.         ENDIF
  214.         END
  215. C-------------------------------------------------------------------
  216. C*      CHEKHED -  CHECK FOR SYNTAX ELEMENT
  217. C         EXIT  -  VAR         I = 1
  218. C                  KEY         I = 2
  219. C                  ATTR        I = 3
  220. C                  BRACKET     I = 4
  221. C                  BOX         I = 5
  222. C                  TABLE       I = 6
  223. C                  TABLE END   I = 7
  224. C                  PANEL       I = 8
  225. C                  SFATTR      I = 9
  226. C                              I = 0 IF NONE
  227. C
  228.         SUBROUTINE CHEKHED(I)
  229. *CALL   COMFPAN
  230.         INTEGER I
  231.         I = 0
  232. 1       IF (SYMEQ(';')) THEN
  233.           CALL SCANSYM
  234.           IF (FATAL) RETURN
  235.           GOTO 1
  236.         ENDIF
  237.         IF(UPSYMEQ('VAR')) THEN
  238.           I = 1
  239.         ELSE IF(UPSYMEQ('KEY')) THEN
  240.           I = 2
  241.         ELSE IF(UPSYMEQ('ATTR')) THEN
  242.           I = 3
  243.         ELSE IF(IMAG(SI,1).EQ.CLDC) THEN
  244.           I = 4
  245.         ELSE IF(UPSYMEQ('BOX')) THEN
  246.           I = 5
  247.         ELSE IF(UPSYMEQ('TABLE')) THEN
  248.           I = 6
  249.         ELSE IF(UPSYMEQ('TABLEND')) THEN
  250.           I = 7
  251.         ELSE IF(UPSYMEQ('PANEL')) THEN
  252.           I = 8
  253.         ELSE IF(UPSYMEQ('SFATTR')) THEN
  254.           I = 9
  255.         ENDIF
  256.         END
  257. C---------------------------------------------------------------------
  258. C*      CHEKKEY - CHECK KEY NAME
  259. C
  260. C       EXIT    G= 1=FUNCTION
  261. C                  2=GENERIC
  262. C               N=KEY NUMBER
  263. C
  264.         SUBROUTINE CHEKKEY(G,N)
  265. *CALL   COMFPAN
  266.         INTEGER G, N
  267.         LOGICAL SHIFT
  268.         SHIFT = .FALSE.
  269.         G = 1
  270.         IF (UPSYMEQ('S').OR.UPSYMEQ('SHIFT')) THEN
  271.           SHIFT = .TRUE.
  272.           CALL SCANSYM
  273.           IF (FATAL) RETURN
  274.         ENDIF
  275.         IF (UPSYMEQ('F1')) THEN
  276.           N = 1
  277.         ELSEIF (UPSYMEQ('F2')) THEN
  278.           N = 2
  279.         ELSEIF (UPSYMEQ('F3')) THEN
  280.           N = 3
  281.         ELSEIF (UPSYMEQ('F4')) THEN
  282.           N = 4
  283.         ELSEIF (UPSYMEQ('F5')) THEN
  284.           N = 5
  285.         ELSEIF (UPSYMEQ('F6')) THEN
  286.           N = 6
  287.         ELSEIF (UPSYMEQ('F7')) THEN
  288.           N = 7
  289.         ELSEIF (UPSYMEQ('F8')) THEN
  290.           N = 8
  291.         ELSEIF (UPSYMEQ('F9')) THEN
  292.           N = 9
  293.         ELSEIF (UPSYMEQ('F10')) THEN
  294.           N = 10
  295.         ELSEIF (UPSYMEQ('F11')) THEN
  296.           N = 11
  297.         ELSEIF (UPSYMEQ('F12')) THEN
  298.           N = 12
  299.         ELSEIF (UPSYMEQ('F13')) THEN
  300.           N = 13
  301.         ELSEIF (UPSYMEQ('F14')) THEN
  302.           N = 14
  303.         ELSEIF (UPSYMEQ('F15')) THEN
  304.           N = 15
  305.         ELSEIF (UPSYMEQ('F16')) THEN
  306.           N = 16
  307.         ELSEIF (UPSYMEQ('F17')) THEN
  308.           N = 17
  309.         ELSEIF (UPSYMEQ('F18')) THEN
  310.           N = 18
  311.         ELSEIF (UPSYMEQ('F19')) THEN
  312.           N = 19
  313.         ELSEIF (UPSYMEQ('F20')) THEN
  314.           N = 20
  315.         ELSEIF (UPSYMEQ('F21')) THEN
  316.           N = 21
  317.         ELSEIF (UPSYMEQ('F22')) THEN
  318.           N = 22
  319.         ELSEIF (UPSYMEQ('F23')) THEN
  320.           N = 23
  321.         ELSEIF (UPSYMEQ('F24')) THEN
  322.           N = 24
  323.         ELSE
  324.           G = 2
  325.           IF (UPSYMEQ('NEXT')) THEN
  326.             N = 1
  327.           ELSEIF (UPSYMEQ('BACK')) THEN
  328.             N = 2
  329.           ELSEIF (UPSYMEQ('HELP')) THEN
  330.             N = 3
  331.           ELSEIF (UPSYMEQ('STOP')) THEN
  332.             N = 4
  333.           ELSEIF (UPSYMEQ('DOWN')) THEN
  334.             N = 5
  335.           ELSEIF (UPSYMEQ('UP')) THEN
  336.             N = 6
  337.           ELSEIF (UPSYMEQ('FWD')) THEN
  338.             N = 7
  339.           ELSEIF (UPSYMEQ('BKW')) THEN
  340.             N = 8
  341.           ELSEIF (UPSYMEQ('EDIT')) THEN
  342.             N = 9
  343.           ELSEIF (UPSYMEQ('DATA')) THEN
  344.             N = 10
  345.           ELSE
  346.             G = 0
  347.           ENDIF
  348.         ENDIF
  349.         IF (SHIFT) THEN
  350.           IF (G.EQ.0) THEN
  351.             CALL ERROR('SHIFT ^N^O^T ^A^L^L^O^W^E^D')
  352.             RETURN
  353.           ENDIF
  354.           N = -N
  355.         ENDIF
  356.         END
  357. C---------------------------------------------------------------------
  358. C*        CHEKPIC - CHECK IF FILL, ENTER, OR KNOW
  359. C
  360. C*        CHEKPIC - CHECK IF X, A, 9, N, E, $, Y , M OR D.
  361. C                   RETURN  FORMAT ORDINAL OR 0 IF NONE.
  362. C
  363.         SUBROUTINE CHEKPIC(I)
  364. *CALL   COMFPAN
  365.         INTEGER I
  366.         IF (UPSYMEQ('X')) THEN
  367.           I = VPX
  368.         ELSE IF (UPSYMEQ('A')) THEN
  369.           I = VPA
  370.         ELSE IF (SYMEQ('9')) THEN
  371.           I = VP9
  372.         ELSE IF (UPSYMEQ('N')) THEN
  373.           I = VPN
  374.         ELSE IF (UPSYMEQ('E')) THEN
  375.           I = VPE
  376.         ELSE IF (SYMEQ('$')) THEN
  377.           I = VPC
  378.         ELSE IF (UPSYMEQ('Y') .OR. UPSYMEQ('YMD')) THEN
  379.           I = VPY
  380.         ELSE IF (UPSYMEQ('M') .OR. UPSYMEQ('MDY')) THEN
  381.           I = VPM
  382.         ELSE IF (UPSYMEQ('D') .OR. UPSYMEQ('DMY')) THEN
  383.           I = VPD
  384.         ELSE
  385.           I = 0
  386.         ENDIF
  387.         END
  388. C-------------------------------------------------------------------
  389. C*      CLEN - RETURN LENGTH OF NAME
  390. C
  391. C       ENTRY   S=STRING
  392. C               7 CHARACTERS OR LESS
  393. C
  394.         INTEGER FUNCTION CLEN(S)
  395.         CHARACTER*(*) S
  396.         I = 7
  397. 1       IF (S(I:I).EQ.' ') THEN
  398.           IF (I.GT.1) THEN
  399.             I = I - 1
  400.             GOTO 1
  401.           ENDIF
  402.         ENDIF
  403.         CLEN = I
  404.         END
  405. C-------------------------------------------------------------------
  406. C*      COMMENT - OUTPUT A COMMENT
  407. C
  408.         SUBROUTINE COMMENT(S)
  409. *CALL   COMFPAN
  410.         CHARACTER*(*) S
  411.         WRITE(3,100) S
  412. 100     FORMAT('*',A)
  413.         END
  414. C-------------------------------------------------------------------
  415. C*      COPYSYM - COPY SYMBOL TO VALIDATION TABLE
  416. C
  417.         SUBROUTINE COPYSYM
  418. *CALL   COMFPAN
  419.         IF (SYMTP.EQ.'S') THEN
  420.           IF (NVAL+SL.GE.MVAL) THEN
  421.             CALL ERROR('VALIDATION TABLE OVERFLOW')
  422.             RETURN
  423.           ENDIF
  424.           NVAL = NVAL + 1
  425.           VVAL(NVAL) = SL
  426.           DO 100 I = 1, SL
  427.             NVAL = NVAL + 1
  428.             VVAL(NVAL) = STRG(I)
  429. 100       CONTINUE
  430.         ELSE
  431.           IF (NVAL+SJ-SI.GE.MVAL) THEN
  432.             CALL ERROR('VALIDATION TABLE OVERFLOW')
  433.             RETURN
  434.           ENDIF
  435.           NVAL = NVAL + 1
  436.           VVAL(NVAL) = SJ - SI
  437.           DO 200 I = SI, SJ - 1
  438.             NVAL = NVAL + 1
  439.             VVAL(NVAL) = IMAG(I,1)
  440. 200       CONTINUE
  441.         ENDIF
  442.         END
  443. C-------------------------------------------------------------------
  444. C*      COPYVAR - INITIALIZE VARIABLE TO SAME AS VARIABLE I
  445. C
  446. C       I - INDEX OF VARIABLE TO COPY
  447. C       J - ROW NUMBER
  448. C
  449. C
  450.         SUBROUTINE COPYVAR(I,J)
  451. *CALL   COMFPAN
  452.         INTEGER I, J
  453.         IF (NVAR.EQ.MVAR) THEN
  454.           CALL ERRORN(MVAR,'^V^A^R^I^A^B^L^E^S')
  455.           RETURN
  456.         ENDIF
  457.         NVAR = NVAR + 1
  458.         VTAB(NVAR) = VTAB(I)
  459.         VAIO(NVAR) = VAIO(I)
  460.         VARL(NVAR) = VARL(I)
  461.         VARV(NVAR) = VARV(I)
  462.         VART(NVAR) = VART(I)
  463.         VARM(NVAR) = VARM(I)
  464.         VARC(NVAR) = VARC(I)
  465.         VARP(NVAR) = VARP(I)
  466.         VAVT(NVAR) = VAVT(I)
  467.         VARH(NVAR) = VARH(I)
  468.         VARD(NVAR) = VARD(I)
  469.         VARA(NVAR) = VARA(I)
  470.         VARF(NVAR) = VARF(I)
  471.         VARR(NVAR) = J
  472.         VARNM(NVAR) = VARNM(I)
  473.         END
  474. C-------------------------------------------------------------------
  475. C*      CORGEN - CORNER GENERATION
  476. C
  477. C       ENTRY
  478. C               I,J=POSITION OF CORNER
  479. C               T= TYPE OF CORNER
  480. C
  481.         SUBROUTINE CORGEN(I,J,T)
  482. *CALL   COMFPAN
  483.         INTEGER I,J,T
  484.         CALL NEWLC(I,J,1,T)
  485.         NCOL = MAX(NCOL,I)
  486.         END
  487. C-------------------------------------------------------------------
  488. C*      CORMOVH - MOVE FROM CORNER TO FOLLOW A HORIZONTAL LINE
  489. C
  490. C       ENTRY
  491. C               I,J=POS OF CORNER
  492. C               II=INCREMENT TO MOVE
  493. C
  494.         SUBROUTINE CORMOVH(I,J,II)
  495. *CALL   COMFPAN
  496.         INTEGER I,J,II
  497.         INTEGER IS
  498.         IS = I
  499. 100     IS = IS + II
  500.         IF (IS.GT.0.AND.IS.LE.MCOL) THEN
  501.           IF (ISLINH(IMAG(IS,J))) GOTO 100
  502.           IF (ISCOR(IMAG(IS,J))) CALL CORSTAK(IS,J)
  503.         ENDIF
  504.         IF (IS.NE.I+II) THEN
  505. C         HAD SOME LINE
  506.             CALL NEWHL(MIN(I+II,IS-II),J,IABS(IS-I)-1)
  507.         ENDIF
  508.         END
  509. C-------------------------------------------------------------------
  510. C*      CORMOVV - MOVE FROM CORNER TO FOLLOW A VERTICAL LINE
  511. C
  512. C       ENTRY
  513. C               I,J=POS OF CORNER
  514. C               JI=INCREMENT TO MOVE
  515. C
  516.         SUBROUTINE CORMOVV(I,J,JI)
  517. *CALL   COMFPAN
  518.         INTEGER I,J,JI
  519.         INTEGER JS
  520.         JS = J
  521. 100     JS = JS + JI
  522.         IF (JS.GT.0.AND.JS.LE.MROW) THEN
  523.           IF (ISLINV(IMAG(I,JS))) GOTO 100
  524.           IF (ISCOR(IMAG(I,JS))) CALL CORSTAK(I,JS)
  525.         ENDIF
  526.         IF (JS.NE.J+JI) THEN
  527. C         HAD SOME LINE
  528.             CALL NEWVL(I,MIN(J+JI,JS-JI),IABS(JS-J)-1)
  529.         ENDIF
  530.         END
  531. C-------------------------------------------------------------------
  532. C*      CORSTAK - CORNER STACK
  533. C
  534. C       ENTRY
  535. C               I,J=POS OF CORNER
  536. C
  537.         SUBROUTINE CORSTAK(I,J)
  538. *CALL   COMFPAN
  539.         INTEGER I,J
  540.         INTEGER CT
  541. C
  542. C       MAKE SURE NOT ALREADY STACKED
  543. C
  544.         IF (IMAG(I,J).EQ.128) RETURN
  545.         IMAG(I,J) = 128
  546. C
  547. C       MAKE SURE CAN STACK
  548. C
  549.         IF (CORS.EQ.MCOR) THEN
  550.           CALL ERROR('B^O^X ^T^O^O ^B^I^G')
  551.           RETURN
  552.         ENDIF
  553. C
  554. C       FIGURE OUT WHAT KIND OF CORNER
  555. C
  556.         CT = 0
  557. C
  558. C       LEFT
  559. C
  560.         IF (I.GT.1) THEN
  561.           IF (ISLCH(IMAG(I-1,J))) THEN
  562.             CT = 1
  563.           ENDIF
  564.         ENDIF
  565. C
  566. C       RIGHT
  567. C
  568.         IF (I.LT.MCOL) THEN
  569.           IF (ISLCH(IMAG(I+1,J))) THEN
  570.             CT = CT + 2
  571.           ENDIF
  572.         ENDIF
  573. C
  574. C       UP
  575. C
  576.         IF (J.GT.1) THEN
  577.           IF (ISLCV(IMAG(I,J-1))) THEN
  578.             CT = CT + 4
  579.           ENDIF
  580.         ENDIF
  581. C
  582. C       DOWN
  583. C
  584.         IF (J.LT.NROW) THEN
  585.           IF (ISLCV(IMAG(I,J+1))) THEN
  586.             CT = CT + 8
  587.           ENDIF
  588.         ENDIF
  589. C
  590. C       NOW STACK IT
  591. C
  592.         CORS = CORS + 1
  593.         CORI(CORS) = I
  594.         CORJ(CORS) = J
  595.         CORT(CORS) = CORO(CT+1)
  596.         END
  597. C-------------------------------------------------------------------
  598. C*      DOBOX - SCAN BOX FROM IMAGE
  599. C
  600. C       ENTRY
  601. C               STARTI,J=POSITION OF BOX CORNER
  602. C               A=INDEX OF BOX
  603. C
  604. C       THE STRATEGY IS TO SCAN THE ENTIRE "BOX", INCLUDING ANY
  605. C       CONNECTED LINES, AND REPLACE IT WITH BLANKS.  NOTE THIS IS
  606. C       A LEGAL BOX (/ REPRESENTS VERTICAL BAR):
  607. C
  608. C                       +-----+       ++
  609. C                   /   /     +-+     //
  610. C                   +---+-----+ +--+--++
  611. C                       /     /    +---+--
  612. C                    ---+-++--+----+
  613. C                         ++  /
  614. C
  615.         SUBROUTINE DOBOX(STARTI,STARTJ,A)
  616. *CALL   COMFPAN
  617.         INTEGER STARTI, STARTJ, A
  618.         INTEGER I,J,T,IE,JE
  619.         INTEGER FIRSTI
  620.         FIRSTI = IBOX + 1
  621. C
  622. C       BOX ATTRIBUTE ORDINAL TO GLOBAL *NBOX*
  623. C
  624.         NBOX = BOXW(A)
  625. C
  626. C       STACK FIRST CORNER
  627. C
  628.         CORS = 0
  629.         I = STARTI
  630.         J = STARTJ
  631.         CALL CORSTAK(I,J)
  632.         IF (FATAL) RETURN
  633. C
  634. C       UNSTACK CORNER AND SCAN IT
  635. C
  636. 100     CONTINUE
  637.         IF (CORS.EQ.0) THEN
  638.           CALL ERASBOX(FIRSTI)
  639.           RETURN
  640.         ENDIF
  641.         I = CORI(CORS)
  642.         J = CORJ(CORS)
  643.         T = CORT(CORS)
  644.         CORS = CORS - 1
  645. C
  646. C       GEN CORNER
  647. C
  648.         CALL CORGEN(I,J,T)
  649. C
  650. C       MOVE LEFT
  651. C
  652.         CALL CORMOVH(I,J,-1)
  653. C
  654. C       MOVE RIGHT
  655. C
  656.         CALL CORMOVH(I,J,1)
  657. C
  658. C       MOVE UP
  659. C
  660.         CALL CORMOVV(I,J,-1)
  661. C
  662. C       MOVE DOWN
  663. C
  664.         CALL CORMOVV(I,J,1)
  665.         GOTO 100
  666.         END
  667. C-------------------------------------------------------------------
  668. C*      EOP - END OF PANEL
  669. C
  670.       SUBROUTINE EOP
  671. *CALL   COMFPAN
  672.       WRITE(3,100) PNAME
  673. 100   FORMAT('.LAST    BSS   0'/
  674.      A       '         END   ',A)
  675.       END
  676. C-------------------------------------------------------------------
  677. C*      ERASBOX - ERASE BOX
  678. C
  679. C       FI - FIRST IBOX IN BOX
  680. C
  681.         SUBROUTINE ERASBOX(FI)
  682. *CALL   COMFPAN
  683.         INTEGER FI
  684.         DO 100 I = FI, IBOX
  685.           IMAG(BOXX(I)+1,BOXY(I)+1) = ZSP
  686. 100     CONTINUE
  687.         END
  688. C-------------------------------------------------------------------
  689. C*      ERR - ERROR
  690. C
  691.       SUBROUTINE ERR(S)
  692. *CALL COMFPAN
  693.       CHARACTER*(*) S
  694.       WRITE(2,'(2A)') ' PANEL INTERNAL ERROR: ',S
  695.       END
  696. C-------------------------------------------------------------------
  697. C*      ERROR - SYNTAX ERROR MESSAGE
  698. C
  699.         SUBROUTINE ERROR(S)
  700. *CALL   COMFPAN
  701.         CHARACTER*(*) S
  702.         IF (INDEF) THEN
  703.           IF (SI.EQ.1) THEN
  704.             WRITE(2,'('' '',A)') '!'
  705.           ELSE
  706.             WRITE(2,'('' '', 2A)') BLANK(1:SI-1), '!'
  707.           ENDIF
  708.         ENDIF
  709.         WRITE(2,1) S
  710. 1       FORMAT(' *ERROR*  ',A)
  711.         FATAL = .TRUE.
  712.         END
  713. C-------------------------------------------------------------------
  714. C*      ERRORN - MORE THAN N OF S
  715. C
  716. C       ENTRY   N=NUMBER
  717. C               S=STRING
  718. C
  719.         SUBROUTINE ERRORN(N,S)
  720. *CALL   COMFPAN
  721.         INTEGER N
  722.         CHARACTER*(*) S
  723.         CHARACTER*80 M
  724.         IF (N.LT.10) THEN
  725.           WRITE(M,'(A,I1,2A)') ' M^O^R^E ^T^H^A^N ', N, ' ', S
  726.         ELSE IF (N.LT.100) THEN
  727.           WRITE(M,'(A,I2,2A)') ' M^O^R^E ^T^H^A^N ', N, ' ', S
  728.         ELSE
  729.           WRITE(M,'(A,I3,2A)') ' M^O^R^E ^T^H^A^N ', N, ' ', S
  730.         ENDIF
  731.         CALL ERROR (M)
  732.         END
  733. C-------------------------------------------------------------------
  734. C*      EXPECT - EXPECT S1 AFTER S2 ERROR
  735. C
  736.       SUBROUTINE EXPECT(S1,S2)
  737. *CALL   COMFPAN
  738.       CHARACTER*(*) S1, S2
  739.       CHARACTER*80 S
  740.       S = ' '
  741.       IF (S2(1:1).EQ.' ') THEN
  742.         S = 'E^X^P^E^C^T^I^N^G '//S1
  743.       ELSE
  744.         S = 'E^X^P^E^C^T^I^N^G '//S1//' ^A^F^T^E^R '//S2
  745.       ENDIF
  746.       CALL ERROR(S)
  747.       END
  748. C-------------------------------------------------------------------
  749. C*      GAL - GENERATE ARRAY LIST
  750. C
  751.         SUBROUTINE GAL
  752. *CALL   COMFPAN
  753.         CALL BLOCK('TABLE LIST')
  754.         CALL LABEL('TABL')
  755.         DO 1000 I = 1,NTAB
  756.           CALL VFD('42/0H'//TABNM(I))
  757.           CALL VFD('18/0')
  758.           CALL VFD('36/0')
  759.           CALL VFDN('8/',TABD(I))
  760.           CALL VFDN('8/',TABR(I))
  761.           CALL VFDN('8/',TABF(I))
  762. 1000    CONTINUE
  763.         IF (NTAB.GT.0) CALL VFD('60/0')
  764.         END
  765. C-------------------------------------------------------------------
  766. C*      GAT - GENERATE ATTRIBUTE TABLE
  767. C
  768.         SUBROUTINE GAT
  769. *CALL   COMFPAN
  770.         CALL BLOCK('ATTRIBUTE TABLE')
  771.         CALL LABEL('ATTR')
  772. C
  773.         DO 1000 I = 1,NATR
  774.           CALL LABELN('ATR',I-1)
  775. C                                               LOGICAL/PHYSICAL
  776.           CALL VFD('1/'//ATRLP(I))
  777. C                                               PROTECT, GUARD
  778.           CALL VFDN('2/',ATIO(I))
  779. C                                               PHYSICAL ATTRIBUTES
  780.           IF (ATRLP(I).EQ.'0') THEN
  781. C                                               RESERVED
  782.             CALL VFD('5/0')
  783. C                                                 UNDERLINE
  784.             CALL VFD('1/'//ATRUL(I))
  785. C                                                 ALT. INTENSITY
  786.             CALL VFD('1/'//ATRAI(I))
  787. C                                                 INVERSE VIDEO
  788.             CALL VFD('1/'//ATRIV(I))
  789. C                                                 BLINK
  790.             CALL VFD('1/'//ATRBL(I))
  791. C                                               LOGICAL ATTRIBUTE
  792.           ELSE
  793. C                                               RESERVED
  794.             CALL VFD('3/0')
  795. C                                                 LOGICAL ORDINAL
  796.             CALL VFDN('6/',ATTP(I))
  797. C                                               END OF ATTRIBUTES
  798.           ENDIF
  799. C                                               RESERVED
  800.           CALL VFD('15/0')
  801. C                                               ATTRIBUTE CHAR START
  802.           CALL VFDN('12/',ATCS(I))
  803. C                                               ATTRIBUTE CHAR END
  804.           CALL VFDN('12/',ATCE(I))
  805. C                                               SPECIAL CHARACTER
  806.           CALL VFDN('2/',ATSC(I))
  807. C                                               BRACKET ID
  808.           CALL VFDN('5/',ATBI(I))
  809. C                                               LINE WEIGHT
  810.           CALL VFDN('2/',ATLW(I))
  811.           CALL COMMENT('*')
  812. 1000    CONTINUE
  813.         END
  814. C-------------------------------------------------------------------
  815. C*      GBL - GENERATE BOX LIST
  816. C
  817.         SUBROUTINE GBL
  818. *CALL   COMFPAN
  819.         INTEGER I
  820.         CALL BLOCK('BOX LIST')
  821.         CALL LABEL('BOXS')
  822.         DO 2000 I = 1, IBOX
  823.           CALL VFDN('12/',BOXA(I)-1)
  824.           CALL VFDN('4/',BOXC(I))
  825.           CALL VFDN('6/',BOXY(I))
  826.           CALL VFDN('9/',BOXX(I))
  827.           CALL VFDN('9/',BOXN(I))
  828.           CALL VFD('20/0')
  829.           CALL COMMENT('*')
  830. 2000    CONTINUE
  831. C                                               TERMINATE BOX LIST
  832.         CALL VFD('60/0')
  833.         END
  834. C-------------------------------------------------------------------
  835. C*      GCD - GENERATE CONSTANT DATA
  836. C
  837.         SUBROUTINE GCD
  838. *CALL   COMFPAN
  839.         CALL BLOCK('CONSTANTS')
  840.         CALL LABEL('CONS')
  841.         DO 100 I = 1, NCON
  842.           CALL LABELN('CON',I)
  843.           CALL VFD('12/7')
  844.           CALL GST(IMAG,CONI(I)+(MCOL+1)*FIEY(CONF(I)),
  845.      A             FIEL(CONF(I)),(FIEL(CONF(I))+6)/5*5-1,
  846.      B             0,O"4000")
  847. 100     CONTINUE
  848.         END
  849. C-------------------------------------------------------------------
  850. C*      GFL - GENERATE FIELD LIST
  851. C
  852.         SUBROUTINE GFL
  853. *CALL   COMFPAN
  854.         CALL BLOCK('FIELDS')
  855.         CALL LABEL('FIEL')
  856.         DO 100 I = 1, NFIE
  857. C                                       FIELD TYPE (1=VAR, 0=CONST)
  858.           CALL VFDN('1/',FIET(I))
  859. C                                       ATTRIBUTE ORDINAL
  860.           CALL VFDN('7/',FIEA(I))
  861. C                                       I/0 (0=NA, 1=OUT, 2=IN, 3=IN/OUT
  862. C                                         CONSTANT ALWAYS 1
  863.           IF (FIET(I).EQ.0) THEN
  864.             CALL VFD('2/1')
  865.           ELSE
  866.             CALL VFDN('2/',3-VAIO(FIEV(I)))
  867.           ENDIF
  868. C                                       VALUE ENTERED, VALID
  869.           CALL VFD('2/0')
  870. C                                       REWRITE
  871.           CALL VFD('1/1')
  872. C                                       ACTIVE
  873.           CALL VFD('1/1')
  874. C                                       RESERVED
  875.           CALL VFD('1/0')
  876. C                                       CONSTANT
  877.           IF (FIET(I).EQ.0) THEN
  878. C                                         RESERVED
  879.             CALL VFD('3/0')
  880. C                                         CONSTANT OFFSET
  881.             CALL VFDN('18/-START+CON',FIEV(I))
  882. C                                       VARIABLE
  883.           ELSE
  884. C                                         VARIABLE ORDINAL
  885.             CALL VFDN('8/',FIEV(I)-1)
  886. C                                         VAR DATA ORDINAL
  887.             CALL VFDN('13/',FIEO(I))
  888.           ENDIF
  889. C                                       LENGTH
  890.           CALL VFDN('9/',FIEL(I))
  891. C                                       LINE
  892.           CALL VFDN('6/',FIEY(I))
  893. C                                       COLUMN
  894.           CALL VFDN('9/',FIEX(I))
  895.           CALL COMMENT(' ')
  896. 100     CONTINUE
  897.         IF (NFIE.GT.0) CALL VFD('60/0')
  898.         END
  899. C-------------------------------------------------------------------
  900. C*      GFT - GENERATE FUNCTION TABLE
  901. C
  902.         SUBROUTINE GFT
  903. *CALL   COMFPAN
  904.         CALL BLOCK('FUNCTIONS')
  905.         CALL LABEL('FUNC')
  906.         DO 1000 I = 1, NFUN
  907.           CALL VFD('44/0')
  908.           CALL VFDN('9/',FUNA(I))
  909.           CALL VFDN('1/',FUNG(I))
  910.           CALL VFDN('6/',FUNK(I))
  911.           CALL COMMENT('*')
  912. 1000    CONTINUE
  913.         IF (NFUN.GT.0) CALL VFD('60/0')
  914.         END
  915. C-------------------------------------------------------------------
  916. C*      GPE - GENERATE PANEL END
  917. C
  918.         SUBROUTINE GPE
  919. *CALL   COMFPAN
  920.         CALL BLOCK('END OF PANEL')
  921.         CALL LABEL('LAST')
  922.         WRITE(3,100) PNAME
  923. 100     FORMAT(T10,'END',T16,A)
  924.         END
  925. C-------------------------------------------------------------------
  926. C*      GPH - GENERATE PANEL HEADER
  927. C
  928.         SUBROUTINE GPH
  929. *CALL   COMFPAN
  930. C
  931.         WRITE(3,100) PNAME, PNAME(1:CLEN(PNAME)), PNAME, PNAME
  932. 100     FORMAT(T10,'IDENT',T16,A/
  933.      A         T10,'LCC',T16,'GROUP(SFPANEL)'/
  934.      B         T10,'LCC',T16,'CAPSULE(',A,')'/
  935.      C         T10,'ENTRY',T16,A/
  936.      D         A,T10,'BSS',T16,'0')
  937.         CALL BLOCK('PANEL HEADER')
  938.         CALL LABEL('START')
  939.         CALL VFD('42/0L'//PNAME)
  940.         CALL VFD('14/0')
  941.         CALL VFDB(WRIB)
  942.         CALL VFDB(ERAR)
  943.         CALL VFDB(ERBW)
  944.         CALL VFDB(BLKA)
  945. C
  946.         CALL COMMENT(' ')
  947.         CALL VFDN('6/',NROW-1)
  948.         CALL VFD('18/LAST-START')
  949.         CALL VFDIF('18/',NFUN,'FUNC-START')
  950.         CALL VFDIF('18/',NVAR,'VARS-START')
  951. C
  952.         CALL COMMENT(' ')
  953.         CALL VFDN('6/',VERS)
  954.         CALL VFD('18/ATTR-START')
  955.         CALL VFDIF('18/',NTAB,'TABL-START')
  956.         CALL VFDIF('18/',NFIE,'FIEL-START')
  957. C
  958.         CALL COMMENT(' ')
  959.         CALL VFD('6/0')
  960.         CALL VFDIF('18/',NBOX,'BOXS-START')
  961.         CALL VFD('12/0')
  962.         CALL VFDN('9/',MSGL)
  963.         CALL VFDN('6/',MSGY)
  964.         CALL VFDN('9/',MSGX)
  965. C
  966.         CALL COMMENT(' ')
  967.         N = 0
  968.         DO 200 I = 1, NFIE
  969.           IF (FIET(I).EQ.1) THEN
  970.             N = N + FIEL(I)
  971.           ENDIF
  972. 200     CONTINUE
  973.         CALL VFDN('13/',N)
  974.         NCOL = MAX(NCOL,MSGL)
  975.         CALL VFDN('9/',NCOL)
  976.         CALL VFD('38/0')
  977.         END
  978. C-------------------------------------------------------------------
  979. C*      GPR - GENERATE PANEL RECORD
  980. C
  981.         SUBROUTINE GPR
  982. *CALL   COMFPAN
  983. C                               PANEL HEADER
  984.         CALL GPH
  985. C                               VAR DATA
  986.         CALL GVD
  987. C                               FIELD LIST
  988.         CALL GFL
  989. C                               CONSTANTS
  990.         CALL GCD
  991. C                               VARIABLES
  992.         CALL GVF
  993. C                                 HELP
  994.         CALL GVH
  995. C                                 VALIDATION
  996.         CALL GVV
  997. C                               FUNCTION KEYS
  998.         CALL GFT
  999. C                               ATTRIBUTES
  1000.         CALL GAT
  1001. C                               TABLES
  1002.         CALL GAL
  1003. C                               BOXES
  1004.         CALL GBL
  1005. C                               END
  1006.         CALL GPE
  1007.         END
  1008. C-------------------------------------------------------------------
  1009. C*      GST - GENERATE STRING FROM ARRAY
  1010. C
  1011. C       ENTRY   A = ARRAY
  1012. C               J = START OF STRING
  1013. C               L = ACTUAL LENGTH OF STRING
  1014. C               ML= MIN AND MAX LENGTH OF STRING
  1015. C               F = FILL CHAR
  1016. C               IAF = CONSTANT TO ADD TO DATA (NOT FILL)
  1017. C
  1018.         SUBROUTINE GST(A,J,L,ML,F,IAF)
  1019. *CALL   COMFPAN
  1020.         INTEGER A(1), J, L, ML, F, IAF
  1021.         LEN = MIN(L,ML)
  1022.         DO 100 I = 0, LEN-1
  1023.           CALL VFDN('12/',A(J+I)+IAF)
  1024. 100     CONTINUE
  1025.         DO 200 I = LEN+1, ML
  1026.           CALL VFDN('12/',F)
  1027. 200     CONTINUE
  1028.         END
  1029. C-------------------------------------------------------------------
  1030. C*      GVD - GENERATE VAR DATA
  1031. C
  1032.         SUBROUTINE GVD
  1033. *CALL   COMFPAN
  1034.         INTEGER N
  1035.         INTEGER NULL(1)
  1036.         DATA NULL/Z"20"/
  1037.         CALL BLOCK('VAR DATA')
  1038.         CALL LABEL('DATA')
  1039.         DO 100 I = 1, NFIE
  1040.           IF (FIET(I).EQ.1) THEN
  1041. C                                               INITIAL VALUE
  1042.             IF (VARD(FIEV(I)).NE.0) THEN
  1043. C                                                 CHAR LEFT JUSTIFIED
  1044.               IF (VART(FIEV(I)).EQ.VTC) THEN
  1045.                 CALL GST(VVAL,VARD(FIEV(I))+1,
  1046.      A                   VVAL(VARD(FIEV(I))),FIEL(I),ZSP,0)
  1047.               ELSE
  1048. C                                                 NUMBERS RIGHT JUSTIFIE
  1049.                 N = VVAL(VARD(FIEV(I))) - FIEL(I)
  1050.                 IF (N.GE.0) THEN
  1051.                   CALL GST(VVAL,VARD(FIEV(I))+1+N,
  1052.      A                     FIEL(I),FIEL(I),ZSP,0)
  1053.                 ELSE
  1054.                   CALL GST(NULL,1,1,-N,ZSP,0)
  1055.                   CALL GST(VVAL,VARD(FIEV(I))+1,
  1056.      A                     VVAL(VARD(FIEV(I))),FIEL(I)+N,ZSP,0)
  1057.                 ENDIF
  1058.               ENDIF
  1059.             ELSE
  1060.               CALL GST(NULL,1,1,FIEL(I),ZSP,0)
  1061.             ENDIF
  1062.           ENDIF
  1063. 100     CONTINUE
  1064.         END
  1065. C-------------------------------------------------------------------
  1066. C*      GVF - GENERATE VARIABLE FIELDS
  1067. C
  1068.         SUBROUTINE GVF
  1069. *CALL   COMFPAN
  1070.         CALL BLOCK('VARIABLES')
  1071.         CALL LABEL('VARS')
  1072.         DO 100 I = 1, NVAR
  1073. C                                       MUST CONTAIN (A VALUE)
  1074.           CALL VFDN('1/',VARC(I))
  1075. C                                       FIELD OFFSET
  1076.           CALL VFDN('9/',VARF(I))
  1077. C                                       ROW NUMBER
  1078.           CALL VFDN('8/',VARR(I))
  1079. C                                       ARRAY ORDINAL
  1080.           CALL VFDN('5/',VTAB(I))
  1081. C                                       MUST ENTER, FILL, KNOW
  1082.           CALL VFDN('3/',VARM(I))
  1083. C                                       TYPE
  1084.           CALL VFDN('2/',VART(I))
  1085. C                                       PICTURE
  1086.           CALL VFDN('8/',VARP(I))
  1087. C                                       VALIDATION
  1088.           CALL VFDN('6/',VAVT(I))
  1089. C                                       VALIDATION OFFSET
  1090.           IF (VARV(I).NE.0) THEN
  1091.             CALL VFDN('18/-START+VAL',I)
  1092.           ELSE
  1093.             CALL VFD('18/0')
  1094.           ENDIF
  1095.         CALL COMMENT(' ')
  1096. C                                       VAR NAME
  1097.         CALL VFD('42/0H'//VARNM(I))
  1098. C                                       HELP
  1099.         IF (VARH(I).NE.0) THEN
  1100.           CALL VFDN('18/-START+HLP',I)
  1101.         ELSE
  1102.           CALL VFD('18/0')
  1103.         ENDIF
  1104.         CALL COMMENT('*')
  1105. C
  1106. 100     CONTINUE
  1107.         IF (NVAR.GT.0) CALL VFD('60/0')
  1108.         END
  1109. C-------------------------------------------------------------------
  1110. C*      GVH - GENERATE VARIABLE HELP
  1111. C
  1112.         SUBROUTINE GVH
  1113. *CALL   COMFPAN
  1114.         CALL BLOCK('HELP')
  1115.         DO 300 I = 1, NVAR
  1116.           IF (VARH(I).NE.0) THEN
  1117.             L = VVAL(VARH(I))
  1118.             IF (L.GT.0) THEN
  1119.               CALL LABELN('HLP',I)
  1120.               CALL VFD('12/7')
  1121.               CALL GST(VVAL,VARH(I)+1,VVAL(VARH(I)),
  1122.      A                 (L+6)/5*5-1,0,O"4000")
  1123.             ENDIF
  1124.           ENDIF
  1125. 300     CONTINUE
  1126.         END
  1127. C-------------------------------------------------------------------
  1128. C*      GVV - GENERATE VARIABLE VALIDATION
  1129. C
  1130.         SUBROUTINE GVV
  1131. *CALL   COMFPAN
  1132.         INTEGER L
  1133.         CALL BLOCK('VALIDATION')
  1134.         DO 300 I = 1, NVAR
  1135.           GOTO (100,200), VAVT(I)
  1136.           GOTO 300
  1137. C
  1138. C         MATCH
  1139. C
  1140. 100       CONTINUE
  1141.           CALL LABELN('VAL',I)
  1142.           J = VARV(I)
  1143. 110       CONTINUE
  1144.           IF (VVAL(J).LT.0) THEN
  1145.             CALL VFD('60/0')
  1146.             GOTO 300
  1147.           ENDIF
  1148.           L = 10
  1149.           IF (VERS.GT.0) L = ((FIEL(VARF(I))+9)/10)*10
  1150.           CALL GST(VVAL,J+1,VVAL(J),L,Z"20",0)
  1151.           J = J + 1 + VVAL(J)
  1152.           CALL COMMENT('*')
  1153.           GOTO 110
  1154. C
  1155. C         RANGE
  1156. C
  1157. 200       CONTINUE
  1158.           CALL LABELN('VAL',I)
  1159.           CALL VFDO('60/',VVAL(VARV(I)))
  1160.           CALL VFDO('60/',VVAL(VARV(I)+1))
  1161. 300     CONTINUE
  1162.         END
  1163. C-------------------------------------------------------------------
  1164. C*      INCI - INCREMENT I POSITION (BUT NOT X)
  1165. C
  1166.         SUBROUTINE INCI
  1167.         SI = SI + 1
  1168.         END
  1169. C-------------------------------------------------------------------
  1170. C*      INCX - INCREMENT X POSITION
  1171. C
  1172.         SUBROUTINE INCX
  1173.         SX = SX + 1
  1174.         SI = SI + 1
  1175.         END
  1176. C-------------------------------------------------------------------
  1177. C*      INCY - INCREMENT Y POSITION
  1178. C
  1179.         SUBROUTINE INCY
  1180.         SJ = SJ + 1
  1181.         END
  1182. C-------------------------------------------------------------------
  1183. C*      ISA - IS ALPHABETIC
  1184. C
  1185. C       ENTRY
  1186. C               C = CHARACTER TO TEST
  1187. C
  1188.         LOGICAL FUNCTION ISA(C)
  1189. *CALL   COMFPAN
  1190.         INTEGER C
  1191.         ISA = C.GE.ZAA.AND.C.LE.ZZZ.OR.
  1192.      A        C.GE.ZA.AND.C.LE.ZZ
  1193.         END
  1194. C-------------------------------------------------------------------
  1195. C*      ISAN - IS ALPHANUMERIC
  1196. C
  1197. C       ENTRY   C=CHARACTER TO TEST
  1198. C
  1199.         LOGICAL FUNCTION ISAN(C)
  1200. *CALL   COMFPAN
  1201.         INTEGER C
  1202.         ISAN = ISA(C).OR.ISN(C)
  1203.         END
  1204. C-------------------------------------------------------------------
  1205. C*      ISCOR - IS A CORNER
  1206. C
  1207. C       ENTRY   C = ASCII CHAR TO TEST
  1208. C
  1209.         LOGICAL FUNCTION ISCOR(C)
  1210. *CALL   COMFPAN
  1211.         INTEGER C
  1212.         ISCOR = (SPCH(C).LT.0.AND.SPCH(C).NE.-128).OR.C.EQ.128
  1213.         END
  1214. C-------------------------------------------------------------------
  1215. C*      ISLCH - IS A HORIZONTAL LINE OR A CORNER
  1216. C
  1217. C       ENTRY   C = ASCII CHAR TO TEST
  1218. C
  1219.         LOGICAL FUNCTION ISLCH(C)
  1220. *CALL   COMFPAN
  1221.         INTEGER C
  1222.         ISLCH = ISCOR(C).OR.ISLINH(C)
  1223.         END
  1224. C-------------------------------------------------------------------
  1225. C*      ISLCV - IS A VERTICAL LINE OR A CORNER
  1226. C
  1227. C       ENTRY   C = ASCII CHAR TO TEST
  1228. C
  1229.         LOGICAL FUNCTION ISLCV(C)
  1230. *CALL   COMFPAN
  1231.         INTEGER C
  1232.         ISLCV = ISCOR(C).OR.ISLINV(C)
  1233.         END
  1234. C-------------------------------------------------------------------
  1235. C*      ISLINH - IS A HORIZONTAL LINE (OF A BOX)
  1236. C
  1237. C       ENTRY   C = ASCII CHAR TO TEST
  1238. C
  1239.         LOGICAL FUNCTION ISLINH(C)
  1240. *CALL   COMFPAN
  1241.         INTEGER C
  1242.         ISLINH = C.EQ.ZMI
  1243.         END
  1244. C-------------------------------------------------------------------
  1245. C*      ISLINV - IS A VERTICAL LINE (OF A BOX)
  1246. C
  1247. C       ENTRY   C = ASCII CHAR TO TEST
  1248. C
  1249.         LOGICAL FUNCTION ISLINV(C)
  1250. *CALL   COMFPAN
  1251.         INTEGER C
  1252.         ISLINV = C.EQ.ZVB
  1253.         END
  1254. C-------------------------------------------------------------------
  1255. C*      ISN - IS NUMERIC
  1256. C
  1257. C       ENTRY
  1258. C               C = CHARACTER TO TEST
  1259. C
  1260.         LOGICAL FUNCTION ISN(C)
  1261. *CALL   COMFPAN
  1262.         INTEGER C
  1263.         ISN = C.GE.Z0.AND.C.LE.Z9
  1264.         END
  1265. C-------------------------------------------------------------------
  1266. C*      ITODC - INTEGER TO DISPLAY CODE FUNCTION
  1267. C
  1268. C       ENTRY
  1269. C               INT = INTEGER TO CONVERT
  1270. C               DC = CHARACTER*10 TO RECEIVE RESULT
  1271. C       EXIT
  1272. C               I =   INDEX TO START OF RESULT IN DC
  1273. C               DC(I:) = RESULT
  1274. C
  1275.       SUBROUTINE ITODC(INT,DC,I)
  1276. *CALL   COMFPAN
  1277.       INTEGER INT, I
  1278.       CHARACTER*10 DC
  1279.       INTEGER N
  1280.       N = IABS(INT)
  1281.       I = 10
  1282. 1     DC(I:I) = CHAR(N - ((N/10)*10) + ICHAR('0'))
  1283.       N = N/10
  1284.       IF (N.EQ.0) THEN
  1285.         IF (INT.LT.0.AND.I.GT.1) THEN
  1286.           I = I - 1
  1287.           DC(I:I) = '-'
  1288.           RETURN
  1289.         ELSEIF (INT.GE.0) THEN
  1290.           RETURN
  1291.         ENDIF
  1292.       ENDIF
  1293.       I = I - 1
  1294.       IF (I.GT.0) GOTO 1
  1295.       DC = '**********'
  1296.       END
  1297. C-------------------------------------------------------------------
  1298. C       LABEL - GENERATE A LABEL
  1299. C
  1300.         SUBROUTINE LABEL(S)
  1301. *CALL   COMFPAN
  1302.         CHARACTER*(*) S
  1303.         WRITE(3,100) S
  1304. 100     FORMAT(A, T10, 'BSS', T16, '0')
  1305.         END
  1306. C-------------------------------------------------------------------
  1307. C*      LABELN - GENERATE A LABEL SUFFIXED BY INTEGER N
  1308. C
  1309. C       ENTRY   S=LABEL NAME
  1310. C               N=LABEL INTEGER
  1311. C
  1312.         SUBROUTINE LABELN(S,N)
  1313. *CALL   COMFPAN
  1314.         CHARACTER*(*) S
  1315.         INTEGER N
  1316.         WRITE(3,100) S, N
  1317. 100     FORMAT(A, I4.4, T10, 'BSS', T16, '0')
  1318.         END
  1319. C-------------------------------------------------------------------
  1320. C*      NEEDHED - ERROR IF NOT VAR, KEY, ATTR OR BRACKET
  1321. C               SKIP FORWARD TO ONE
  1322. C
  1323.         SUBROUTINE NEEDHED(I)
  1324. *CALL   COMFPAN
  1325.         INTEGER I
  1326.         IF (FATAL) CALL SKIPHED
  1327.         CALL CHEKHED(I)
  1328.         IF(I.EQ.0) THEN
  1329.           CALL EXPECT('VAR, KEY, ATTR, BOX, TABLE ^O^R ^2',' ')
  1330.           CALL SKIPHED
  1331.         ENDIF
  1332.         END
  1333. C-------------------------------------------------------------------
  1334. C*      NEWATR - NEW ATTRIBUTE
  1335. C
  1336.         SUBROUTINE NEWATR
  1337. *CALL   COMFPAN
  1338.         IF (NATR.GE.MATR) THEN
  1339.           CALL ERRORN(MATR,'^A^T^T^R^I^B^U^T^E^S')
  1340.           RETURN
  1341.         ENDIF
  1342.         NATR = NATR + 1
  1343.         ATCS(NATR) = 0
  1344.         ATCE(NATR) = 0
  1345.         ATSC(NATR) = 0
  1346.         ATRLP(NATR) = '1'
  1347.         ATRUL(NATR) = '0'
  1348.         ATRAI(NATR) = '0'
  1349.         ATRIV(NATR) = '0'
  1350.         ATRBL(NATR) = '0'
  1351.         ATTP(NATR) = 0
  1352.         ATBI(NATR) = 0
  1353.         ATLW(NATR) = 0
  1354.         ATIO(NATR) = 2
  1355.         END
  1356. C-------------------------------------------------------------------
  1357. C*      NEWCON - NEW CONSTANT
  1358. C
  1359. C       ENTRY
  1360. C               X = X POSITION ON SCREEN
  1361. C               Y = Y POSITION ON SCREEN
  1362. C               I = COLUMN IN IMAG ARRAY
  1363. C               L = NUMBER OF CHARACTERS
  1364. C               A = ATTRIBUTE ORDINAL
  1365. C
  1366.         SUBROUTINE NEWCON(X,Y,I,L,A)
  1367. *CALL   COMFPAN
  1368.         INTEGER X,Y,I,L,A
  1369.         IF (NFIE.GE.(MFIE)) THEN
  1370.           CALL ERRORN(MFIE,'TOTAL C^O^N^S^T^A^N^T ^A^N^D V^A^R^I^A^B^L^E
  1371.      + ^F^I^E^L^D^S')
  1372.           RETURN
  1373.         ENDIF
  1374.         IF (NCON.GT.MCON) THEN
  1375.           CALL ERRORN(NCON,'C^O^N^S^T^A^N^T ^F^I^E^L^D^S')
  1376.           RETURN
  1377.         ENDIF
  1378.         NCON = NCON + 1
  1379.         NFIE = NFIE + 1
  1380.         FIEX(NFIE) = X
  1381.         FIEY(NFIE) = Y
  1382.         FIEL(NFIE) = L
  1383.         FIET(NFIE) = 0
  1384.         FIEV(NFIE) = NCON
  1385.         FIEO(NFIE) = 0
  1386.         FIEA(NFIE) = A
  1387.         CONI(NCON) = I
  1388.         CONF(NCON) = NFIE
  1389.         END
  1390. C-------------------------------------------------------------------
  1391. C*      NEWHL - NEW HORIZONTAL LINE
  1392. C
  1393. C       ENTRY
  1394. C               I,J=START OF LINE
  1395. C               L = LENGTH
  1396. C
  1397.         SUBROUTINE NEWHL(I,J,L)
  1398. *CALL   COMFPAN
  1399.         INTEGER I,J,L
  1400.         CALL NEWLC(I,J,L,0)
  1401.         DO 100 K = 1, L
  1402.           IMAG(I+K-1,J) = ZSP
  1403. 100     CONTINUE
  1404.         NCOL = MAX(NCOL,I+L-1)
  1405.         END
  1406. C-------------------------------------------------------------------
  1407. C*      NEWLC - NEW LINE OR CORNER
  1408. C
  1409. C       ENTRY
  1410. C               I,J= POS ON SCREEN
  1411. C               L = LEN FOR LINE
  1412. C               T = TYPE (BOXHL, BOXVL, OR CORNER TYPE)
  1413. C
  1414.         SUBROUTINE NEWLC(I,J,L,T)
  1415. *CALL   COMFPAN
  1416.         INTEGER I,J,L,T
  1417.         IF (IBOX.GT.255) THEN
  1418.           CALL ERRORN(256,'^B^O^X^ ^E^L^E^M^E^N^T^S')
  1419.           RETURN
  1420.         ENDIF
  1421.         IBOX = IBOX + 1
  1422.         BOXN(IBOX) = L
  1423.         BOXX(IBOX) = I - 1
  1424.         BOXY(IBOX) = J - 1
  1425.         BOXC(IBOX) = T
  1426.         BOXA(IBOX) = NBOX
  1427.         END
  1428. C-------------------------------------------------------------------
  1429. C*      NEWVAR - INITIALIZE VARIABLE
  1430. C
  1431.         SUBROUTINE NEWVAR
  1432. *CALL   COMFPAN
  1433.         IF (NVAR.EQ.MVAR) THEN
  1434.           CALL ERRORN(MVAR,'^V^A^R^I^A^B^L^E^S')
  1435.           RETURN
  1436.         ENDIF
  1437.         NVAR = NVAR + 1
  1438.         VTAB(NVAR) = 0
  1439.         VAIO(NVAR) = 0
  1440.         VARL(NVAR) = 0
  1441.         VARV(NVAR) = 0
  1442.         VART(NVAR) = VTC
  1443.         VARM(NVAR) = VMK
  1444.         VARC(NVAR) = 0
  1445.         VARP(NVAR) = 0
  1446.         VAVT(NVAR) = 0
  1447.         VARH(NVAR) = 0
  1448.         VARD(NVAR) = 0
  1449.         VARA(NVAR) = 1
  1450.         VARF(NVAR) = 0
  1451.         VARR(NVAR) = 0
  1452.         VARNM(NVAR) = '*'
  1453.         END
  1454. C-------------------------------------------------------------------
  1455. C*      NEWVAT - NEW VARIABLE ATTRIBUTE
  1456. C
  1457.         SUBROUTINE NEWVAT
  1458. *CALL   COMFPAN
  1459.         IF (VARA(NVAR).EQ.1) THEN
  1460.           CALL NEWATR
  1461.           IF (FATAL) RETURN
  1462.           ATIO(NATR) = 0
  1463.           VARA(NVAR) = NATR - 1
  1464.         ENDIF
  1465.         END
  1466. C-------------------------------------------------------------------
  1467. C*      NEWVL - NEW VERTICAL LINE
  1468. C
  1469. C       ENTRY
  1470. C               I,J= POS OF START OF LINE
  1471. C               L=LENGTH
  1472. C
  1473.         SUBROUTINE NEWVL(I,J,L)
  1474. *CALL   COMFPAN
  1475.         INTEGER I,J,L
  1476.         CALL NEWLC(I,J,L,1)
  1477.         DO 100 K = 1, L
  1478.           IMAG(I,J+K-1) = ZSP
  1479. 100     CONTINUE
  1480.         END
  1481. C-------------------------------------------------------------------
  1482. C*      PACKATR - PACK ATTRIBUTES DOWN
  1483. C
  1484. C       CHECK THE ATTRIBUTE LIST TO SEE IF NATR IS UNIQUE.
  1485. C       IF NOT, POP NATR AND RETURN THE ORDINAL OF THE
  1486. C       IDENTICAL ATTRIBUTE.  IF SO, RETURN NATR.
  1487. C
  1488.         INTEGER FUNCTION PACKATR()
  1489. *CALL   COMFPAN
  1490.         INTEGER I
  1491.         DO 100 I = 1, NATR-1
  1492.           IF (ATRLP(NATR).EQ.ATRLP(I).AND.
  1493.      A        ATRUL(NATR).EQ.ATRUL(I).AND.
  1494.      B        ATRAI(NATR).EQ.ATRAI(I).AND.
  1495.      C        ATRIV(NATR).EQ.ATRIV(I).AND.
  1496.      D        ATRBL(NATR).EQ.ATRBL(I).AND.
  1497.      E        ATIO(NATR).EQ.ATIO(I).AND.
  1498.      F        ATTP(NATR).EQ.ATTP(I).AND.
  1499.      H        ATCS(NATR).EQ.ATCS(I).AND.
  1500.      I        ATCE(NATR).EQ.ATCE(I).AND.
  1501.      J        ATSC(NATR).EQ.ATSC(I).AND.
  1502.      K        ATBI(NATR).EQ.ATBI(I).AND.
  1503.      L        ATLW(NATR).EQ.ATLW(I)) GOTO 200
  1504. 100     CONTINUE
  1505.         PACKATR = NATR
  1506.         RETURN
  1507. 200     PACKATR = I
  1508.         NATR = NATR - 1
  1509.         END
  1510. C-------------------------------------------------------------------
  1511. C*      QUIT - ABNORMALLY TERMINATE THE JOB
  1512. C
  1513. C       ENTRY   M=MESSAGE TO DISPLAY
  1514. C
  1515.         SUBROUTINE QUIT(M)
  1516. *CALL   COMFPAN
  1517.         CHARACTER*(*) M
  1518.         CHARACTER*80 MESSAGE
  1519.         MESSAGE = ' ERROR IN ' // PNAME(1:CLEN(PNAME)) //
  1520.      A            ' ' // M // ':::'
  1521.         CALL QUITS(MESSAGE)
  1522.         END
  1523. C-------------------------------------------------------------------
  1524. C*      QUITS - ABNORMALLY TERMINATE THE JOB FOR SYSTEM REASONS
  1525. C
  1526. C       ENTRY   M=MESSAGE TO DISPLAY
  1527. C
  1528.         SUBROUTINE QUITS(M)
  1529. *CALL   COMFPAN
  1530.         CHARACTER*(*) M
  1531.         CHARACTER*80 MESSAGE
  1532.         MESSAGE = ' PANEL - ' // M //    ':::'
  1533.         REWIND 1
  1534.         REWIND 2
  1535.         REWIND 3
  1536.         CALL MSG(MESSAGE)
  1537.         CALL ABT
  1538.         END
  1539. C-------------------------------------------------------------------
  1540. C*      READL1 - READ A LINE INTO LINE
  1541. C
  1542.         SUBROUTINE READL1
  1543. *CALL   COMFPAN
  1544.         READ(1,100,END=999) LINE
  1545. 100     FORMAT(A)
  1546.         WRITE(2,150) LINE
  1547. 150     FORMAT(' ',A)
  1548.         CALL XLINE(1)
  1549.         SJ = 1
  1550.         RETURN
  1551. 999     CONTINUE
  1552.         IF (INDEF) THEN
  1553.           CALL ERROR('U^N^E^X^P^E^C^T^E^D ^E^N^D ^O^F ^F^I^L^E')
  1554.           CALL QUIT ('END OF FILE DURING DEFINITIONS')
  1555.         ELSE
  1556.           CALL QUIT ('NO DEFINITION OR IMAGE')
  1557.         ENDIF
  1558.         ENDFILE = .TRUE.
  1559.         END
  1560. C-------------------------------------------------------------------
  1561. C*      RPI - READ PANEL IMAGE
  1562. C
  1563.         SUBROUTINE RPI
  1564. *CALL   COMFPAN
  1565.         DO 200 I = 2,MROW+1
  1566.           READ(1,100,END=300) LINE
  1567. 100       FORMAT(A)
  1568.           WRITE(2,150) LINE
  1569. 150       FORMAT(' ',A)
  1570.           IF (I.LE.MROW) THEN
  1571.             CALL XLINE(I)
  1572.           ENDIF
  1573. 200     CONTINUE
  1574.         CALL ERROR('PANEL IMAGE EXCEEDS 64 LINES')
  1575.         NROW = MROW
  1576.         RETURN
  1577. 300     CONTINUE
  1578.         NROW = I - 1
  1579.         END
  1580. C-------------------------------------------------------------------
  1581. C*      SCANATR - SCAN ATTRIBUTE
  1582. C
  1583.         SUBROUTINE SCANATR
  1584. *CALL   COMFPAN
  1585.         LOGICAL HAVDEL
  1586.         HAVDEL = .FALSE.
  1587.         N = 0
  1588. 1       CONTINUE
  1589.         CALL SCANSYM
  1590.         IF (FATAL) RETURN
  1591. 2       CONTINUE
  1592.         IF (ZEQNEXT()) THEN
  1593.           IF (UPSYMEQ('DELIMITERS').OR.UPSYMEQ('D')) THEN
  1594.             I = 1
  1595.           ELSEIF (UPSYMEQ('PHYSICAL').OR.UPSYMEQ('P')) THEN
  1596.             I = 2
  1597.           ELSEIF (UPSYMEQ('LOGICAL').OR.UPSYMEQ('L')) THEN
  1598.             I = 3
  1599.           ELSE
  1600.             CALL EXPECT('DELIMITERS, LOGICAL, ^O^R PHYSICAL',
  1601.      A                  'ATTR')
  1602.             RETURN
  1603.           ENDIF
  1604.           CALL SKIPTWO
  1605.           IF (FATAL) RETURN
  1606.           GOTO (100,200,300), I
  1607.         ELSE
  1608.           CALL CHEKHED(J)
  1609.           IF (J.NE.0) THEN
  1610.             IF (.NOT.HAVDEL) THEN
  1611.               CALL EXPECT('DELIMITERS','ATTR')
  1612.               RETURN
  1613.             ENDIF
  1614.             RETURN
  1615.           ENDIF
  1616.           N = N + 1
  1617.           GOTO (100,200,300), N
  1618.           CALL ERROR('T^O^O ^M^A^N^Y ATTR ^P^A^R^A^M^E^T^E^R^S')
  1619.           RETURN
  1620.         ENDIF
  1621. C
  1622. C       DELIMITERS
  1623. C
  1624. 100     CONTINUE
  1625.         HAVDEL = .TRUE.
  1626.         CALL NEWATR
  1627.         IF (FATAL) RETURN
  1628.         IF (SYMTP.EQ.'S') THEN
  1629.           IF (SL.EQ.1) THEN
  1630.             ATCS(NATR) = STRG(1)
  1631.             ATCE(NATR) = STRG(1)
  1632.           ELSEIF (SL.EQ.2) THEN
  1633.             ATCS(NATR) = STRG(1)
  1634.             ATCE(NATR) = STRG(2)
  1635.           ELSE
  1636.             CALL ERROR('S^T^R^I^N^G ^L^E^N^G^T^H')
  1637.             RETURN
  1638.           ENDIF
  1639.           SPCH(ATCS(NATR)) = NATR
  1640.         ELSE
  1641.           CALL EXPECT('Q^U^O^T^E^D ^D^E^L^I^M^I^T^E^R^S',' ')
  1642.           RETURN
  1643.         ENDIF
  1644.         SPCH(ATCS(NATR)) = NATR
  1645.         GOTO 1
  1646. C
  1647. C       PHYSICAL
  1648. C
  1649. 200     CONTINUE
  1650.         CALL SCANLPA(0)
  1651.         IF (FATAL) RETURN
  1652.         GOTO 1
  1653. C
  1654. C       LOGICAL
  1655. C
  1656. 300     CONTINUE
  1657.         CALL SCANLPA(1)
  1658.         IF (FATAL) RETURN
  1659.         GOTO 1
  1660.         END
  1661. C-------------------------------------------------------------------
  1662. C*      SCANBOX - SCAN BOX
  1663. C
  1664.         SUBROUTINE SCANBOX
  1665. *CALL   COMFPAN
  1666.         INTEGER I, N
  1667.         LOGICAL HAVCH
  1668.         HAVCH = .FALSE.
  1669.         IF (NBOX.GE.MBOX) THEN
  1670.           CALL ERRORN(MBOX,'^B^O^X^E^S')
  1671.           RETURN
  1672.         ENDIF
  1673.         CALL NEWATR
  1674.         IF (FATAL) RETURN
  1675.         NBOX = NBOX + 1
  1676.         BOXW(NBOX) = NATR
  1677.         ATLW(NATR) = 1
  1678.         ATTP(NATR) = 1
  1679.         N = 0
  1680. 1       CONTINUE
  1681.         CALL SCANSYM
  1682.         IF (ZEQNEXT()) THEN
  1683.           IF (UPSYMEQ('TERMINATOR').OR.UPSYMEQ('T')) THEN
  1684.             I = 1
  1685.           ELSEIF (UPSYMEQ('WEIGHT').OR.UPSYMEQ('W')) THEN
  1686.             I = 2
  1687.           ELSEIF (UPSYMEQ('PHYSICAL').OR.UPSYMEQ('P')) THEN
  1688.             I = 3
  1689.           ELSEIF (UPSYMEQ('LOGICAL').OR.UPSYMEQ('L')) THEN
  1690.             I = 4
  1691.           ELSE
  1692.             CALL EXPECT('TERMINATOR= ^O^R WEIGHT=','BOX')
  1693.             RETURN
  1694.           ENDIF
  1695.           CALL SKIPTWO
  1696.           IF (FATAL) RETURN
  1697.           N = 4
  1698.           GOTO (100,200,300,400), I
  1699.         ELSE
  1700.           CALL CHEKHED(I)
  1701.           IF (I.NE.0) THEN
  1702.             IF (.NOT.HAVCH) THEN
  1703.               CALL ERROR('TERMINATOR ^C^H^A^R ^R^E^Q^U^I^R^E^D')
  1704.             ENDIF
  1705.             RETURN
  1706.           ENDIF
  1707.           N = N + 1
  1708.           GOTO (100,200,300,400), N
  1709.           CALL EXPECT('E^N^D ^O^F BOX ^D^E^C^L^A^R^A^T^I^O^N',' ')
  1710.           RETURN
  1711.         ENDIF
  1712. C
  1713. C       TERMINATOR
  1714. C
  1715. 100     CONTINUE
  1716.         HAVCH = .TRUE.
  1717.         IF (FATAL) RETURN
  1718.         IF (SYMTP.NE.'S'.OR.SL.NE.1) THEN
  1719.           CALL EXPECT('TERMINATOR ^C^H^A^R^A^C^T^E^R',' ')
  1720.           RETURN
  1721.         ENDIF
  1722.         IF (SPCH(IMAG(SI,1)).NE.0) THEN
  1723.           CALL ERROR('D^O^U^B^L^Y ^D^E^F^I^N^E^D')
  1724.           RETURN
  1725.         ENDIF
  1726.         SPCH(STRG(1)) = -NBOX
  1727.         GOTO 1
  1728. C
  1729. C       WEIGHT
  1730. C
  1731. 200     CONTINUE
  1732.         IF (UPSYMEQ('FINE').OR.UPSYMEQ('F')) THEN
  1733.           ATLW(NATR) = 1
  1734.         ELSEIF (UPSYMEQ('MEDIUM').OR.UPSYMEQ('M')) THEN
  1735.           ATLW(NATR) = 2
  1736.         ELSEIF (UPSYMEQ('BOLD').OR.UPSYMEQ('B')) THEN
  1737.           ATLW(NATR) = 3
  1738.         ELSE
  1739.           CALL EXPECT('FINE, MEDIUM, ^O^R BOLD','WEIGHT=')
  1740.           RETURN
  1741.         ENDIF
  1742.         GOTO 1
  1743. C
  1744. C       PHYSICAL
  1745. C
  1746. 300     CONTINUE
  1747.         CALL SCANLPA(0)
  1748.         IF (FATAL) RETURN
  1749.         GOTO 1
  1750. C
  1751. C       LOGICAL
  1752. C
  1753. 400     CONTINUE
  1754.         CALL SCANLPA(1)
  1755.         IF (FATAL) RETURN
  1756.         GOTO 1
  1757.         END
  1758. C-------------------------------------------------------------------
  1759. C*      SCANCAS - SCAN CASE LIST
  1760. C
  1761. C       CASE CONSTANTS ARE COPIED TO THE VVAL ARRAY.  EACH CONSTANT
  1762. C       IS PRECEDED BY ITS LENGTH.  THE LIST IS TERMINATED BY A LENGTH
  1763. C       OF -1.
  1764. C
  1765.         SUBROUTINE SCANCAS
  1766. *CALL   COMFPAN
  1767.         SAVV = NVAL + 1
  1768.         IF (.NOT.SYMEQ('(')) THEN
  1769.           CALL EXPECT('^L^I^S^T','MATCH')
  1770.           RETURN
  1771.         ENDIF
  1772.         N = 0
  1773. 1       CONTINUE
  1774.         CALL SCANSYM
  1775.         IF (FATAL) RETURN
  1776.         IF (SYMEQ(')')) THEN
  1777.           IF (N.EQ.0) THEN
  1778.             CALL ERROR('E^M^P^T^Y MATCH ^L^I^S^T')
  1779.             RETURN
  1780.           ENDIF
  1781.           IF (NVAL.GE.MVAL) THEN
  1782.             CALL ERR('VALIDATION TABLE OVERFLOW')
  1783.             RETURN
  1784.           ENDIF
  1785.           NVAL = NVAL + 1
  1786.           VVAL(NVAL) = -1
  1787.           VARV(NVAR) = SAVV
  1788.           VAVT(NVAR) = VTMATCH
  1789.           RETURN
  1790.         ENDIF
  1791.         N = N + 1
  1792.         CALL COPYSYM
  1793.         IF (FATAL) RETURN
  1794.         GOTO 1
  1795.         END
  1796. C-------------------------------------------------------------------
  1797. C*      SCANDEF - SCAN PANEL DEFINITION
  1798. C
  1799.         SUBROUTINE SCANDEF
  1800. *CALL   COMFPAN
  1801.         INTEGER I, J, N
  1802.         LOGICAL INTABL
  1803.         INTABL = .FALSE.
  1804. 2       CALL SCANSYM
  1805. 1       CONTINUE
  1806.         IF (SYMEQ(';')) GOTO 2
  1807.         ABEND = ABEND.OR.FATAL
  1808.         IF (.NOT.INDEF) RETURN
  1809.         CALL NEEDHED(I)
  1810.         ABEND = ABEND.OR.FATAL
  1811.         IF (ENDFILE) RETURN
  1812.         FATAL = .FALSE.
  1813.         GOTO (100,200,300,400,500,600,700,800,900),I
  1814.         RETURN
  1815. C
  1816. C       VAR
  1817. C
  1818. 100     CONTINUE
  1819.  
  1820. * INITIALIZE DEFAULT LOGICAL ATTRIBUTES FLAG.
  1821.  
  1822.         DEFLOGA = .TRUE.
  1823.         CALL SCANVAR
  1824.  
  1825. * TYPE IO=OUT WITH DEFAULT LOGICAL ATTRIBUTES IS SET TO LOGICAL=TEXT.
  1826.  
  1827.         IF ((DEFLOGA) .AND.(VAIO(NVAR) .EQ. 2)) THEN
  1828.           ATTP(NATR) = 1
  1829.         ENDIF
  1830.         IF (FATAL) GOTO 1
  1831.         IF (INTABL) THEN
  1832.           VTAB(NVAR) = NTAB
  1833.         ENDIF
  1834.         IF (VARA(NVAR).EQ.NATR-1) THEN
  1835.           VARA(NVAR) = PACKATR() - 1
  1836.         ENDIF
  1837.         GOTO 1
  1838. C
  1839. C       KEY
  1840. C
  1841. 200     CALL SCANKEY
  1842.         GOTO 1
  1843. C
  1844. C       ATTR
  1845. C
  1846. 300     CALL SCANATR
  1847.         GOTO 1
  1848. C
  1849. C       RIGHT CURLY BRACKET
  1850. C
  1851. 400     CALL READL1
  1852.         RETURN
  1853. C
  1854. C         BOX
  1855. C
  1856. 500     CALL SCANBOX
  1857.         IF (FATAL) GOTO 2
  1858.         GOTO 1
  1859. C
  1860. C       TABLE
  1861. C
  1862. 600     CONTINUE
  1863.         IF (INTABL) THEN
  1864.           CALL ERROR('A^L^R^E^A^D^Y ^I^N ^T^A^B^L^E')
  1865.           CALL SCANSYM
  1866.           GOTO 1
  1867.         ENDIF
  1868.         INTABL = .TRUE.
  1869.         IF (NTAB.GE.MTAB) THEN
  1870.           CALL ERRORN(MTAB,'^T^A^B^L^E^S')
  1871.           RETURN
  1872.         ENDIF
  1873.         NTAB = NTAB + 1
  1874.         TABNM(NTAB) = '*'
  1875.         TABD(NTAB) = 1
  1876.         TABF(NTAB) = NVAR + 1
  1877.         CALL SCANTAB
  1878.         IF (FATAL) RETURN
  1879.         GOTO 1
  1880. C
  1881. C       ENDTABLE
  1882. C
  1883. 700     CONTINUE
  1884.         CALL SCANSYM
  1885.         IF (FATAL) RETURN
  1886.         IF (.NOT.INTABL) THEN
  1887.           CALL ERROR('N^O^T ^I^N ^T^A^B^L^E')
  1888.           GOTO 1
  1889.         ENDIF
  1890.         INTABL = .FALSE.
  1891.         IF (TABF(NTAB).GT.NVAR) THEN
  1892.           CALL ERROR('E^M^P^T^Y ^T^A^B^L^E')
  1893.           NTAB = NTAB - 1
  1894.           GOTO 1
  1895.         ENDIF
  1896.         TABR(NTAB) = NVAR + 1 - TABF(NTAB)
  1897.         N = NVAR
  1898.         DO 750 I = 1, TABD(NTAB)-1
  1899.           DO 750 J = TABF(NTAB), N
  1900.             CALL COPYVAR(J,I)
  1901. 750     CONTINUE
  1902.         TABL(NTAB) = NVAR
  1903.         GOTO 1
  1904. C
  1905. C       PANEL
  1906. C
  1907. 800     CONTINUE
  1908.         CALL SCANPAN
  1909.         GOTO 1
  1910. C
  1911. C       SFATTR
  1912. C
  1913. 900     CONTINUE
  1914.         IF (NATR.GT.3) THEN
  1915.           CALL ERROR('SFATTR AFTER OTHER ATTRIBUTES')
  1916.           ABEND = .TRUE.
  1917.           RETURN
  1918.         ENDIF
  1919.         CALL SCANSYM
  1920.         IF (FATAL) RETURN
  1921.         DO 950 J = 0,2
  1922.           DO 950 I = 0,11
  1923.             NATR = NATR + 1
  1924.             ATRLP(NATR) = '1'
  1925.             ATIO(NATR) = J
  1926.             ATTP(NATR) = I
  1927. 950     CONTINUE
  1928.         GOTO 1
  1929.         END
  1930. C-------------------------------------------------------------------
  1931. C*      SCANIMG - SCAN PANEL IMAGE
  1932. C
  1933.         SUBROUTINE SCANIMG
  1934. *CALL   COMFPAN
  1935.         CHARACTER*7 VNAME
  1936.         INTEGER HIHV
  1937. C
  1938. C       PREPARE IMAGE
  1939. C
  1940.         DO 1 J = 1, MROW
  1941.           IMAG(MCOL+1,J) = 1
  1942. 1       CONTINUE
  1943. C
  1944. C       START COUNTING VAR DATA AND VARS FOUND
  1945. C
  1946.         VDCO = 0
  1947.         NVAF = 0
  1948.         HIHV = NVAR
  1949.         LFIE = 0
  1950.         NFIE = 0
  1951.         SPCH(128) = -128
  1952.         SPCH(ZUL) = -128
  1953. C
  1954. C       SCAN
  1955. C
  1956.         DO 1000 J = 1, NROW
  1957.           I = 1
  1958. C
  1959. C         SKIP BLANKS
  1960. C
  1961. 100       IF (I.LE.MCOL) THEN
  1962.             IF (IMAG(I,J).EQ.ZSP) THEN
  1963.               I = I + 1
  1964.               GOTO 100
  1965.             ENDIF
  1966. C
  1967. C           VARIABLE
  1968. C
  1969.             K = SPCH(IMAG(I,J))
  1970.             IF (IMAG(I,J).EQ.ZUL) THEN
  1971.               IF ((J.EQ.1) .AND.
  1972.      A          (VAIO(NFIE+1) .NE. 2)) THEN
  1973.                 CALL ERROR('I^N^P^U^T ^F^I^E^L^D ^O^N' //
  1974.      A                     ' ^F^I^R^S^T ^L^I^N^E ^O^F ^I^M^A^G^E')
  1975.                 RETURN
  1976.               ENDIF
  1977.               SI = I
  1978.               TMPX = I - 1
  1979. 200           I = I + 1
  1980.               IF (IMAG(I,J).EQ.ZUL) GOTO 200
  1981.               NCOL = MAX(NCOL,I-1)
  1982.               NFIE = NFIE + 1
  1983.               NVAF = NVAF + 1
  1984.               IF (NVAF.LE.NVAR) THEN
  1985.                 IF (I-SI.NE.VARL(NVAF).AND.VARL(NVAF).NE.0) THEN
  1986.                   CALL ERROR('FIELD DECLARED DIFFERENT SIZE')
  1987.                 ENDIF
  1988.               ELSE
  1989.                 CALL NEWVAR
  1990.                 IF (FATAL) RETURN
  1991.               ENDIF
  1992.               FIEX(NFIE) = TMPX
  1993.               FIEY(NFIE) = J - 1
  1994.               FIEL(NFIE) = I - SI
  1995.               FIET(NFIE) = 1
  1996.               FIEV(NFIE) = NVAF
  1997.               FIEO(NFIE) = VDCO
  1998.               FIEA(NFIE) = VARA(NVAF)
  1999.               VARF(NVAF) = NFIE
  2000.               VDCO = VDCO + FIEL(NFIE)
  2001.               GOTO 100
  2002. C
  2003. C           ATTRIBUTE
  2004. C
  2005.             ELSEIF (K.GT.0) THEN
  2006.               SI = I + 1
  2007. 300           I = I + 1
  2008.               IF (I.LE.MCOL.AND.IMAG(I,J).NE.ATCE(K)) GOTO 300
  2009.               NCOL = MAX(NCOL,I-1)
  2010.               IF (I-SI.GT.0) THEN
  2011.                 CALL NEWCON(SI-1, J-1, SI, I-SI, K-1)
  2012.                 IF (FATAL) RETURN
  2013.               ENDIF
  2014.               I = I + 1
  2015.               GOTO 100
  2016. C
  2017. C           BOX
  2018. C
  2019.             ELSEIF (K.LT.0) THEN
  2020.               CALL DOBOX(I,J,-K)
  2021.               I = I + 1
  2022.               GOTO 100
  2023. C
  2024. C           PLAIN OLD CONSTANT
  2025. C
  2026.             ELSE
  2027.               SI = I
  2028. 400           I = I + 1
  2029.               IF (I.LE.MCOL.AND.
  2030.      A            IMAG(I,J).NE.ZSP.AND.
  2031.      B            SPCH(IMAG(I,J)).EQ.0) GOTO 400
  2032.               IF (I.LT.MCOL.AND.
  2033.      A            IMAG(I,J).EQ.ZSP.AND.
  2034.      B            IMAG(I+1,J).NE.ZSP) GOTO 400
  2035.               NCOL = MAX(NCOL,I-1)
  2036.               CALL NEWCON(SI-1, J-1, SI, I-SI, 2)
  2037.               IF (FATAL) RETURN
  2038.               GOTO 100
  2039.             ENDIF
  2040.           ENDIF
  2041. 1000    CONTINUE
  2042.         IF (HIHV.NE.NVAR.OR.NVAF.NE.NVAR) THEN
  2043.           CALL ERROR('D^I^F^F^E^R^E^N^T ^N^U^M^B^E^R ^O^F' //
  2044.      A               ' ^F^I^E^L^D^S ^T^H^A^N ^D^E^C^L^A^R^E^D')
  2045.         ENDIF
  2046.         END
  2047. C-------------------------------------------------------------------
  2048. C*      SCANINT - SCAN INTEGER
  2049. C
  2050.         SUBROUTINE SCANINT
  2051. *CALL   COMFPAN
  2052. 1       IF (ISN(IMAG(SJ,1))) THEN
  2053.           SJ = SJ + 1
  2054.           GOTO 1
  2055.         ENDIF
  2056.         END
  2057. C-------------------------------------------------------------------
  2058. C       SCANKEY - SCAN KEY DECLARATION
  2059. C
  2060.         SUBROUTINE SCANKEY
  2061. *CALL   COMFPAN
  2062.         N = 0
  2063.         CALL SCANSYM
  2064. 1       CONTINUE
  2065.         IF (FATAL) RETURN
  2066.         IF (ZEQNEXT()) THEN
  2067.           IF (UPSYMEQ('NORMAL').OR.UPSYMEQ('N')) THEN
  2068.             I = 1
  2069.           ELSEIF (UPSYMEQ('ABNORMAL').OR.UPSYMEQ('A')) THEN
  2070.             I = 2
  2071.           ELSEIF (UPSYMEQ('HELP').OR.UPSYMEQ('H')) THEN
  2072.             I = 3
  2073.           ELSEIF (UPSYMEQ('MATCH').OR.UPSYMEQ('M')) THEN
  2074.             I = 4
  2075.           ELSE
  2076.             CALL EXPECT('NORMAL=, ABNORMAL=, HELP= ^O^R MATCH=','KEY')
  2077.             RETURN
  2078.           ENDIF
  2079.           CALL SKIPTWO
  2080.           IF (FATAL) RETURN
  2081.           N = 4
  2082.           GOTO (100,200,300,400), I
  2083.         ELSE
  2084.           N = N + 1
  2085.           GOTO (100,200,300,400), N
  2086.           CALL CHEKHED(I)
  2087.           IF (I.EQ.0) THEN
  2088.             CALL EXPECT('NORMAL=, ABNORMAL=, HELP= ^O^R '//
  2089.      A                 'MATCH=(^K^E^Y^S)','KEY')
  2090.           ENDIF
  2091.           RETURN
  2092.         ENDIF
  2093. C
  2094. C       NORMAL
  2095. C
  2096. 100     CONTINUE
  2097.         CALL SCANKYS(1)
  2098.         IF (FATAL) RETURN
  2099.         GOTO 1
  2100. C
  2101. C       ABNORMAL
  2102. C
  2103. 200     CONTINUE
  2104.         CALL SCANKYS(3)
  2105.         IF (FATAL) RETURN
  2106.         GOTO 1
  2107. C
  2108. C       HELP
  2109. C
  2110. 300     CONTINUE
  2111.         CALL SCANKYS(9)
  2112.         IF (FATAL) RETURN
  2113.         GOTO 1
  2114. C
  2115. C       MATCH
  2116. C
  2117. 400     CONTINUE
  2118.         CALL SCANKYS(10)
  2119.         IF (FATAL) RETURN
  2120.         GOTO 1
  2121.         END
  2122. C-------------------------------------------------------------------
  2123. C*      SCANKYS - SCAN KEY LIST
  2124. C
  2125. C       ENTRY   K=ACTION
  2126. C
  2127.         SUBROUTINE SCANKYS(K)
  2128. *CALL   COMFPAN
  2129.         LOGICAL LOOP
  2130.         IF (SYMEQ('(')) THEN
  2131.           LOOP = .TRUE.
  2132.           GOTO 1
  2133.         ELSE
  2134.           LOOP = .FALSE.
  2135.           GOTO 2
  2136.         ENDIF
  2137. 1       CONTINUE
  2138.         CALL SCANSYM
  2139.         IF (FATAL) RETURN
  2140. 2       CONTINUE
  2141.         CALL CHEKKEY(I,J)
  2142.         IF (FATAL) RETURN
  2143.         IF (I.EQ.0) THEN
  2144.           IF (LOOP) THEN
  2145.             IF (SYMEQ(')')) THEN
  2146.               CALL SCANSYM
  2147.             ELSE
  2148.               CALL EXPECT(')','KEY ^L^I^S^T')
  2149.             ENDIF
  2150.           ENDIF
  2151.           RETURN
  2152.         ENDIF
  2153.         IF (NFUN.GE.MFUN) THEN
  2154.           CALL ERRORN(MKEY,'^K^E^Y^S')
  2155.           RETURN
  2156.         ENDIF
  2157.         NFUN = NFUN + 1
  2158.         FUNG(NFUN) = I/2
  2159.         FUNK(NFUN) = J
  2160.         FUNA(NFUN) = K
  2161.         IF (LOOP) GOTO 1
  2162.         CALL SCANSYM
  2163.         END
  2164. C-------------------------------------------------------------------
  2165. C       SCANLEN - SCAN VAR LENGTH
  2166. C
  2167.         SUBROUTINE SCANLEN
  2168. *CALL   COMFPAN
  2169.         IF (SYMEQ('(')) THEN
  2170.           CALL SCANSYM
  2171.           IF (FATAL) RETURN
  2172.           IF (SYMTP.EQ.'N') THEN
  2173.             VARL(NVAR) = SINT
  2174.             CALL SCANSYM
  2175.             IF (FATAL) RETURN
  2176.             IF (SYMEQ(')')) THEN
  2177.               CALL SCANSYM
  2178.               RETURN
  2179.             ELSE
  2180.               CALL EXPECT(')','VAR ^L^E^N^G^T^H')
  2181.             ENDIF
  2182.           ELSE
  2183.             CALL EXPECT('VAR ^L^E^N^G^T^H','(')
  2184.           ENDIF
  2185.         ENDIF
  2186.         VARL(NVAR) = 0
  2187.         END
  2188. C-------------------------------------------------------------------
  2189. C*      SCANLPA - SCAN LOGICAL/PHYSICAL ATTRIBUTE
  2190. C
  2191. C       ENTRY   LOG=1 IF LOGICAL ATTRIBUTES, 0 IF PHYSICAL
  2192. C
  2193.         SUBROUTINE SCANLPA(LOG)
  2194. *CALL   COMFPAN
  2195.         INTEGER LOG
  2196.         LOGICAL LOOP
  2197.         CHARACTER*8 LOGIC(2)
  2198.         DATA LOGIC /'PHYSICAL','LOGICAL'/
  2199.         IF (SYMEQ('(')) THEN
  2200.           LOOP = .TRUE.
  2201.           GOTO 1
  2202.         ELSE
  2203.           LOOP = .FALSE.
  2204.           GOTO 2
  2205.         ENDIF
  2206. 1       CONTINUE
  2207.         CALL SCANSYM
  2208.         IF (FATAL) RETURN
  2209. 2       CONTINUE
  2210.         CALL CHEKATR(LP,I)
  2211.         IF (LP.EQ.3) THEN
  2212.           IF (SYMEQ(')')) RETURN
  2213.           CALL EXPECT(LOGIC(LOG+1)//' ^A^T^T^R^I^B^U^T^E',' ')
  2214.           RETURN
  2215.         ENDIF
  2216.         IF (LP.NE.LOG) THEN
  2217.           CALL ERROR('^A^T^T^R^I^B^U^T^E ^N^O^T '//LOGIC(LOG+1))
  2218.           RETURN
  2219.         ENDIF
  2220.         CALL SETATR(LP,I)
  2221.         IF (LOOP) GOTO 1
  2222.         END
  2223. C-------------------------------------------------------------------
  2224. C*      SCANMUS - SCAN ENTRY
  2225. C
  2226.         SUBROUTINE SCANMUS
  2227. *CALL   COMFPAN
  2228.         LOGICAL LOOP
  2229.         IF (SYMEQ('(')) THEN
  2230.           LOOP = .TRUE.
  2231.           GOTO 1
  2232.         ELSE
  2233.           LOOP = .FALSE.
  2234.           GOTO 2
  2235.         ENDIF
  2236. 1       CONTINUE
  2237.         CALL SCANSYM
  2238.         IF (FATAL) RETURN
  2239. 2       CONTINUE
  2240.         IF (SYMEQ(')')) RETURN
  2241.         IF (UPSYMEQ('MUST')) THEN
  2242.           CALL SCANSYM
  2243.           IF (FATAL) RETURN
  2244.         ENDIF
  2245.         IF (UPSYMEQ('FILL')) THEN
  2246.           VARM(NVAR) = OR(VARM(NVAR),VMF)
  2247.         ELSEIF (UPSYMEQ('ENTER').OR.UPSYMEQ('E')) THEN
  2248.           VARM(NVAR) = OR(VARM(NVAR),VME)
  2249.         ELSEIF (UPSYMEQ('UNKNOWN').OR.UPSYMEQ('U')) THEN
  2250.           VARM(NVAR) = AND(VARM(NVAR),COMPL(VMK))
  2251.         ELSEIF (UPSYMEQ('CONTAIN').OR.UPSYMEQ('C')) THEN
  2252.           VARC(NVAR) = 1
  2253.         ELSE
  2254.           CALL EXPECT('MUST FILL, ENTER, CONTAIN ^O^R UNKNOWN','ENTRY')
  2255.           RETURN
  2256.         ENDIF
  2257.         IF (LOOP) GOTO 1
  2258.         END
  2259. C-------------------------------------------------------------------
  2260. C*      SCANPAN - SCAN PANEL KEYWORDS
  2261. C
  2262.         SUBROUTINE SCANPAN
  2263. *CALL   COMFPAN
  2264.         N = 0
  2265. 1       CONTINUE
  2266.         CALL SCANSYM
  2267.         IF (FATAL) RETURN
  2268.         IF (ZEQNEXT()) THEN
  2269.           IF (UPSYMEQ('NAME').OR.UPSYMEQ('N')) THEN
  2270.             I = 1
  2271.           ELSE IF (UPSYMEQ('TYPE').OR.UPSYMEQ('T')) THEN
  2272.             I = 2
  2273.           ELSE
  2274.             CALL EXPECT('TYPE=','PANEL')
  2275.             RETURN
  2276.           ENDIF
  2277.           CALL SKIPTWO
  2278.           IF (FATAL) RETURN
  2279.           N = 2
  2280.           GOTO (100,200), I
  2281.         ELSE
  2282.           CALL CHEKHED(I)
  2283.           IF (I.NE.0) RETURN
  2284.           N = N + 1
  2285.           GOTO (100,200), N
  2286.           CALL EXPECT('NAME ^O^R TYPE','PANEL')
  2287.           RETURN
  2288.         ENDIF
  2289. C
  2290. C       NAME
  2291. C
  2292. 100     CONTINUE
  2293.         IF (SYMTP.NE.'I') THEN
  2294.           CALL EXPECT('PANEL ^N^A^M^E','PANEL')
  2295.           RETURN
  2296.         ENDIF
  2297.         PNAME = STRGD(1:SL)
  2298.         GOTO 1
  2299. C
  2300. C       TYPE
  2301. C
  2302. 200     CONTINUE
  2303.         IF (UPSYMEQ('PRIMARY')) THEN
  2304.           ERBW = 1
  2305.         ELSEIF (UPSYMEQ('OVERLAY')) THEN
  2306.           ERBW = 0
  2307.         ELSE
  2308.           CALL EXPECT('PRIMARY ^O^R OVERLAY',' ')
  2309.           RETURN
  2310.         ENDIF
  2311.         GOTO 1
  2312.         END
  2313. C-------------------------------------------------------------------
  2314. C*      SCANRNG - SCAN RANGE
  2315. C
  2316.         SUBROUTINE SCANRNG
  2317. *CALL   COMFPAN
  2318.         IF (.NOT.SYMEQ('(')) THEN
  2319.           CALL EXPECT('(','RANGE=')
  2320.           RETURN
  2321.         ENDIF
  2322.         CALL SCANSYM
  2323.         IF (FATAL) RETURN
  2324.         IF (SYMTP.NE.'N'.AND.SYMTP.NE.'R') THEN
  2325.           CALL EXPECT('^C^O^N^S^T^A^N^T','RANGE')
  2326.           RETURN
  2327.         ENDIF
  2328. C
  2329. C       INTEGER RANGE
  2330. C
  2331.         IF (NVAL.GE.MVAL-1) THEN
  2332.           CALL ERR('VALIDATION TABLE OVERFLOW')
  2333.           RETURN
  2334.         ENDIF
  2335.         IF (VART(NVAR).EQ.VTN) THEN
  2336.           IF (SYMTP.NE.'N') THEN
  2337.             CALL ERROR('C^O^N^S^T^A^N^T ^W^R^O^N^G ^T^Y^P^E')
  2338.             RETURN
  2339.           ENDIF
  2340.           NVAL = NVAL + 1
  2341.           VVAL(NVAL) = SINT
  2342.           CALL SCANSYM
  2343.           IF (FATAL) RETURN
  2344.           IF (SYMTP.NE.'N') THEN
  2345.             CALL EXPECT('^C^O^N^S^T^A^N^T^S','RANGE')
  2346.             RETURN
  2347.           ENDIF
  2348.           IF (VVAL(NVAL).GT.SINT) THEN
  2349.             CALL ERROR('RANGE ^L^O^W ^G^T ^H^I^G^H')
  2350.             RETURN
  2351.           ENDIF
  2352.           NVAL = NVAL + 1
  2353.           VVAL(NVAL) = SINT
  2354.           VARV(NVAR) = NVAL - 1
  2355.           VAVT(NVAR) = VTRANGE
  2356.           CALL SCANSYM
  2357.           GOTO 9999
  2358. C
  2359. C       REAL RANGE
  2360. C
  2361.         ELSEIF (VART(NVAR).EQ.VTR) THEN
  2362.           IF (SYMTP.NE.'R') THEN
  2363.             CALL ERROR('C^O^N^S^T^A^N^T ^W^R^O^N^G ^T^Y^P^E')
  2364.             RETURN
  2365.           ENDIF
  2366.           NVAL = NVAL + 1
  2367.           VREALV(NVAL) = SREALV
  2368.           CALL SCANSYM
  2369.           IF (FATAL) RETURN
  2370.           IF (SYMTP.NE.'R') THEN
  2371.             CALL EXPECT('^C^O^N^S^T^A^N^T^S','RANGE')
  2372.             RETURN
  2373.           ENDIF
  2374.           IF (VREALV(NVAL).GT.SREALV) THEN
  2375.             CALL ERROR('RANGE ^L^O^W ^G^T ^H^I^G^H')
  2376.             RETURN
  2377.           ENDIF
  2378.           NVAL = NVAL + 1
  2379.           VREALV(NVAL) = SREALV
  2380.           VARV(NVAR) = NVAL - 1
  2381.           VAVT(NVAR) = VTRANGE
  2382.           CALL SCANSYM
  2383.           GOTO 9999
  2384. C
  2385. C       CHAR RANGE
  2386. C
  2387.         ELSE
  2388.           CALL ERROR('RANGE ^O^F CHAR ^N^O^T ^A^L^L^O^W^E^D')
  2389.           RETURN
  2390.         ENDIF
  2391. 9999    CONTINUE
  2392.         IF (FATAL) RETURN
  2393.         IF (.NOT.SYMEQ(')')) THEN
  2394.           CALL EXPECT(')','RANGE')
  2395.         ENDIF
  2396.         END
  2397. C-------------------------------------------------------------------
  2398. C*      SCANSYM - SCAN SYMBOL FROM CURRENT POSITION
  2399. C
  2400. C       ENTRY
  2401. C               SJ = CURRENT POSITION
  2402. C       EXIT
  2403. C               SI = SYMBOL POSITION
  2404. C               SJ = NEW CURRENT POSITION
  2405. C               SYMTP = SYMBOL TYPE
  2406. C                       I = IDENTIFIER
  2407. C                       N = INTEGER
  2408. C                       P = PUNCTUATOR
  2409. C                       R = REAL
  2410. C                       S = STRING
  2411. C
  2412.         SUBROUTINE SCANSYM
  2413. *CALL   COMFPAN
  2414.         CHARACTER*10 FMT
  2415.         GOTO 2
  2416. 1       CALL READL1
  2417.         IF (FATAL) RETURN
  2418. 2       CONTINUE
  2419.         IF (SJ.GT.MCOL) GOTO 1
  2420.         IF (IMAG(SJ,1).EQ.ZSP) THEN
  2421.           SJ = SJ + 1
  2422.           GOTO 2
  2423.         ENDIF
  2424.         IF (IMAG(SJ,1).EQ.ZQO) THEN
  2425. 3         CONTINUE
  2426.           SJ = SJ + 1
  2427.           IF (SJ.GT.MCOL) GOTO 1
  2428.           IF (IMAG(SJ,1).NE.ZQO) GOTO 3
  2429.           SJ = SJ + 1
  2430.           GOTO 2
  2431.         ENDIF
  2432. C
  2433.         SI = SJ
  2434.         SL = 0
  2435.         IF (ISA(IMAG(SJ,1))) THEN
  2436.           GOTO 100
  2437.         ELSEIF (ISN(IMAG(SJ,1))) THEN
  2438.           GOTO 200
  2439.         ELSEIF (IMAG(SJ,1).EQ.ZPL.OR.
  2440.      A          IMAG(SJ,1).EQ.ZMI) THEN
  2441.           GOTO 200
  2442.         ELSEIF (IMAG(SJ,1).EQ.ZPD) THEN
  2443.           IF (IMAG(SJ+1,1).EQ.ZPD) THEN
  2444.             SJ = SJ + 2
  2445.             IF (IMAG(SJ,1).EQ.ZPD) SJ = SJ + 1
  2446.             GOTO 2
  2447.           ENDIF
  2448.           GOTO 215
  2449.         ELSEIF (IMAG(SJ,1).EQ.ZAP) THEN
  2450.           SJ = SJ + 1
  2451.           GOTO 300
  2452.         ENDIF
  2453.         SYMTP = 'P'
  2454.         SL = 1
  2455.         SJ = SJ + 1
  2456.         GOTO 9999
  2457. C
  2458. C       IDENTIFIER
  2459. C
  2460. 100     IF (ISAN(IMAG(SJ,1))) THEN
  2461.           SL = SL + 1
  2462.           IF (IMAG(SJ,1).LT.ZAA) THEN
  2463.             STRGD(SL:SL) = CHAR(IMAG(SJ,1) - Z0 + ICHAR('0'))
  2464.           ELSE IF (IMAG(SJ,1).GT.ZZZ) THEN
  2465.             STRGD(SL:SL) = CHAR(IMAG(SJ,1) - ZA + ICHAR('A'))
  2466.           ELSE
  2467.             STRGD(SL:SL) = CHAR(IMAG(SJ,1) - ZAA + ICHAR('A'))
  2468.           ENDIF
  2469.           SJ = SJ + 1
  2470.           GOTO 100
  2471.         ENDIF
  2472.         SYMTP = 'I'
  2473.         GOTO 9999
  2474. C
  2475. C       NUMBER
  2476. C
  2477. C       PLUS OR MINUS
  2478. 200     CONTINUE
  2479.         SIGN = 1
  2480.         SINT = 0
  2481.         SYMTP = 'N'
  2482.         IF(IMAG(SJ,1).EQ.ZPL) THEN
  2483.           SL = SL + 1
  2484.           STRGD(SL:SL) = '+'
  2485.           SJ = SJ + 1
  2486.         ELSEIF (IMAG(SJ,1).EQ.ZMI) THEN
  2487.           SL = SL + 1
  2488.           STRGD(SL:SL) = '-'
  2489.           SIGN = -1
  2490.           SJ = SJ + 1
  2491.         ENDIF
  2492. C       DIGITS
  2493. 210     IF (ISN(IMAG(SJ,1))) THEN
  2494.           SL = SL + 1
  2495.           STRGD(SL:SL) = CHAR(IMAG(SJ,1) - Z0 + ICHAR('0'))
  2496.           SINT = SINT*10 + IMAG(SJ,1) - Z0
  2497.           SJ = SJ + 1
  2498.           GOTO 210
  2499.         ENDIF
  2500.         IF (IMAG(SJ,1).NE.ZPD.AND.IMAG(SJ,1).NE.ZE.AND.
  2501.      A      IMAG(SJ,1).NE.ZEE) THEN
  2502.           SINT = SINT * SIGN
  2503.           GOTO 9999
  2504.         ENDIF
  2505.         SYMTP = 'R'
  2506. C       DECIMAL POINT
  2507. 215     IF (IMAG(SJ,1).EQ.ZPD) THEN
  2508.           SL = SL + 1
  2509.           STRGD(SL:SL) = '.'
  2510.           SJ = SJ + 1
  2511.         ENDIF
  2512. C       MORE DIGITS
  2513. 220     IF (ISN(IMAG(SJ,1))) THEN
  2514.           SL = SL + 1
  2515.           STRGD(SL:SL) = CHAR(IMAG(SJ,1) - Z0 + ICHAR('0'))
  2516.           SJ = SJ + 1
  2517.           GOTO 220
  2518.         ENDIF
  2519. C       E
  2520.         IF (IMAG(SJ,1).EQ.ZEE.OR.IMAG(SJ,1).EQ.ZE) THEN
  2521.           SL = SL + 1
  2522.           STRGD(SL:SL) = 'E'
  2523.           SJ = SJ + 1
  2524.           SYMTP = 'R'
  2525.         ENDIF
  2526. C       PLUS OR MINUS AGAIN
  2527.         IF(IMAG(SJ,1).EQ.ZPL) THEN
  2528.           SL = SL + 1
  2529.           STRGD(SL:SL) = '+'
  2530.           SJ = SJ + 1
  2531.         ELSEIF (IMAG(SJ,1).EQ.ZMI) THEN
  2532.           SL = SL + 1
  2533.           STRGD(SL:SL) = '-'
  2534.           SJ = SJ + 1
  2535.         ENDIF
  2536. C       STILL MORE DIGITS
  2537. 230     IF (ISN(IMAG(SJ,1))) THEN
  2538.           SL = SL + 1
  2539.           STRGD(SL:SL) = CHAR(IMAG(SJ,1) - Z0 + ICHAR('0'))
  2540.           SJ = SJ + 1
  2541.           GOTO 230
  2542.         ENDIF
  2543. C       GET VALUE
  2544.         IF (SYMTP.EQ.'N') THEN
  2545.           SINT = SINT * SIGN
  2546.         ELSE
  2547.           WRITE(FMT,285) SL
  2548. 285       FORMAT('(F',I2,'.0)')
  2549. C         PRINT*,'REAL FORMAT=',FMT,' VALUE=',STRGD(1:SL)
  2550.           READ(STRGD(1:SL),FMT,ERR=290) SREALV
  2551. C         PRINT 57, SREALV
  2552. 57        FORMAT(E20.10)
  2553.         ENDIF
  2554.         GOTO 9999
  2555. 290     CALL ERROR('R^E^A^L ^C^O^N^S^T^A^N^T ^F^O^R^M^A^T')
  2556.         SREALV = 0.0
  2557.         GOTO 9999
  2558. C
  2559. C       STRING
  2560. C
  2561. 300     CONTINUE
  2562.         IF (SJ.GT.MCOL) THEN
  2563.           CALL ERROR('U^N^T^E^R^M^I^N^A^T^E^D ^S^T^R^I^N^G')
  2564.           RETURN
  2565.         ENDIF
  2566.         IF (IMAG(SJ,1).EQ.ZAP) THEN
  2567.           SJ = SJ + 1
  2568.           IF (SJ.GT.MCOL) GOTO 300
  2569.           IF (IMAG(SJ,1).EQ.ZAP) THEN
  2570.             SL = SL + 1
  2571.             STRG(SL) = IMAG(SJ,1)
  2572.             SJ = SJ + 1
  2573.             GOTO 300
  2574.           ENDIF
  2575.         ELSE
  2576.           SL = SL + 1
  2577.           STRG(SL) = IMAG(SJ,1)
  2578.           SJ = SJ + 1
  2579.           GOTO 300
  2580.         ENDIF
  2581.         SYMTP = 'S'
  2582. 9999    CONTINUE
  2583.         IF (SYMTP.EQ.'P') THEN
  2584. C         PRINT 55, SYMTP, IMAG(SI,1)
  2585. 55        FORMAT('SCANSYM ',A,' ', O3)
  2586.         ELSE
  2587. C         PRINT 56, SYMTP, SL, STRGD(1:SL)
  2588. 56        FORMAT('SCANSYM ',A,' ',I3,' ',A)
  2589.         ENDIF
  2590.         END
  2591. C-------------------------------------------------------------------
  2592. C*      SCANTAB - SCAN TABLE DEFINITION
  2593. C
  2594.         SUBROUTINE SCANTAB
  2595. *CALL   COMFPAN
  2596.         LOGICAL HAVNAME, HAVDIM
  2597.         HAVNAME = .FALSE.
  2598.         HAVDIM = .FALSE.
  2599.         N = 0
  2600. 1       CONTINUE
  2601.         CALL SCANSYM
  2602.         IF (FATAL) RETURN
  2603.         IF (ZEQNEXT()) THEN
  2604.           IF (UPSYMEQ('NAME').OR.UPSYMEQ('N')) THEN
  2605.             I = 1
  2606.           ELSE IF (UPSYMEQ('ROWS').OR.UPSYMEQ('R')) THEN
  2607.             I = 2
  2608.           ELSE
  2609.             CALL EXPECT('NAME= ^O^R ROWS=','TABLE')
  2610.             RETURN
  2611.           ENDIF
  2612.           CALL SKIPTWO
  2613.           IF (FATAL) RETURN
  2614.           N = 2
  2615.           GOTO (100,200), I
  2616.         ELSE
  2617.           N = N + 1
  2618.           GOTO (100,200), N
  2619.           IF (.NOT.HAVNAME) THEN
  2620.             CALL ERROR('TABLE ^N^A^M^E ^R^E^Q^U^I^R^E^D')
  2621.             RETURN
  2622.           ENDIF
  2623.           IF (.NOT.HAVDIM) THEN
  2624.             CALL ERROR('TABLE ^D^I^M^E^N^S^I^O^N '//
  2625.      A                 '^R^E^Q^U^I^R^E^D')
  2626.             RETURN
  2627.           ENDIF
  2628.           CALL CHEKHED(I)
  2629.           IF (I.EQ.0) THEN
  2630.             CALL ERROR('TABLE ^P^A^R^A^M^E^T^E^R')
  2631.           ENDIF
  2632.           RETURN
  2633.         ENDIF
  2634. C
  2635. C       NAME
  2636. C
  2637. 100     CONTINUE
  2638.         IF (SYMTP.NE.'I') THEN
  2639.           CALL EXPECT('TABLE ^N^A^M^E',' ')
  2640.           RETURN
  2641.         ENDIF
  2642.         HAVNAME = .TRUE.
  2643.         TABNM(NTAB) = STRGD(1:MIN(7,SL))
  2644.         GOTO 1
  2645. C
  2646. C       ROWS
  2647. C
  2648. 200     CONTINUE
  2649.         IF (.NOT.SYMTP.EQ.'N') THEN
  2650.           CALL EXPECT('T^A^B^L^E ^D^I^M^E^N^S^I^O^N',' ')
  2651.           RETURN
  2652.         ENDIF
  2653.         TABD(NTAB) = SINT
  2654.         HAVDIM = .TRUE.
  2655.         GOTO 1
  2656.         END
  2657. C-------------------------------------------------------------------
  2658. C*      SCANVAR - GET VARIABLE DEFINITION
  2659. C
  2660.         SUBROUTINE SCANVAR
  2661. *CALL   COMFPAN
  2662.         LOGICAL HAVENAM
  2663.         LOGICAL LOOP
  2664.         HAVENAM = .FALSE.
  2665.         NPARM = 0
  2666. 1       CONTINUE
  2667.         CALL SCANSYM
  2668.         IF (FATAL) RETURN
  2669. 2       CONTINUE
  2670.         CALL SCANVKS(I)
  2671.         IF (FATAL) RETURN
  2672.         IF (I.EQ.0) THEN
  2673.           CALL CHEKHED(J)
  2674.           IF (FATAL) RETURN
  2675.           IF (J.NE.0) THEN
  2676.             IF (.NOT.HAVENAM) THEN
  2677.               CALL ERROR('VAR ^N^A^M^E ^N^O^T ^S^P^E^C^I^F^I^E^D')
  2678.               RETURN
  2679.             ENDIF
  2680.             IF ((VART(NVAR).EQ.VTN.OR.VART(NVAR).EQ.VTR).AND.
  2681.      A          (VARP(NVAR).LT.VP9)) THEN
  2682.               CALL ERROR('TYPE/FORMAT ^M^I^S^M^A^T^C^H ^I^N '//
  2683.      A                   '^P^R^E^C^E^D^I^N^G VAR')
  2684.               RETURN
  2685.             ENDIF
  2686.             IF (VARP(NVAR).EQ.0) VARP(NVAR) = VPX
  2687.             RETURN
  2688.           ENDIF
  2689.           NPARM = NPARM + 1
  2690.           GOTO (100,200,300,400,500,600,
  2691.      A          700,800,900,1000,1100), NPARM
  2692.           CALL ERROR('T^O^O ^M^A^N^Y VAR ^P^A^R^A^M^E^T^E^R^S')
  2693.           RETURN
  2694.         ELSE
  2695.           NPARM = 11
  2696.           GOTO (100,200,300,400,500,600,
  2697.      A          700,800,900,1000,1100), I
  2698.           CALL ERR('INTERNAL ERROR: VAR KEYWORD')
  2699.           RETURN
  2700.         ENDIF
  2701. C
  2702. C       NAME
  2703. C
  2704. 100     CONTINUE
  2705.         IF (HAVENAM) THEN
  2706.           CALL ERROR('T^W^O VAR ^N^A^M^E^S')
  2707.           RETURN
  2708.         ENDIF
  2709.         IF (SYMTP.NE.'I') THEN
  2710.           CALL EXPECT('^V^A^R ^N^A^M^E','VAR')
  2711.           RETURN
  2712.         ELSE
  2713.           CALL SETVARN
  2714.           IF (FATAL) RETURN
  2715.         ENDIF
  2716.         HAVENAM = .TRUE.
  2717.         GOTO 1
  2718. C
  2719. C       TYPE
  2720. C
  2721. 200     CONTINUE
  2722.         IF (UPSYMEQ('CHAR')) THEN
  2723.           VART(NVAR) = VTC
  2724.           IF (VARP(NVAR).EQ.0) VARP(NVAR) = VPX
  2725.         ELSEIF (UPSYMEQ('INT')) THEN
  2726.           VART(NVAR) = VTN
  2727.           IF (VARP(NVAR).EQ.0) VARP(NVAR) = VPN
  2728.         ELSEIF (UPSYMEQ('REAL')) THEN
  2729.           VART(NVAR) = VTR
  2730.           IF (VARP(NVAR).EQ.0) VARP(NVAR) = VPE
  2731.         ELSE
  2732.           CALL EXPECT('CHAR, INT, ^O^R REAL','TYPE')
  2733.           RETURN
  2734.         ENDIF
  2735.         GOTO 1
  2736. C
  2737. C       VALUE
  2738. C
  2739. 300     CONTINUE
  2740.         CALL SETVARD
  2741.         IF (FATAL) RETURN
  2742.         GOTO 1
  2743. C
  2744. C       FORMAT
  2745. C
  2746. 400     CONTINUE
  2747.         CALL CHEKPIC(I)
  2748.         IF (I.EQ.0) THEN
  2749.           CALL EXPECT('X, A, 9, N, E, $, YMD, MDY, ^O^R DMY','FORMAT')
  2750.           RETURN
  2751.         ENDIF
  2752.         VARP(NVAR) = I
  2753.         GOTO 1
  2754. C
  2755. C       MATCH
  2756. C
  2757. 500     CONTINUE
  2758.         CALL SCANCAS
  2759.         IF (FATAL) RETURN
  2760.         GOTO 1
  2761. C
  2762. C       LOGICAL
  2763. C
  2764. 800     CONTINUE
  2765.  
  2766. * RESET DEFAULT LOGICAL ATTRIBUTES FLAG.
  2767.  
  2768.         DEFLOGA = .FALSE.
  2769.         CALL SCANVAT(1)
  2770.         IF (FATAL) RETURN
  2771.         GOTO 1
  2772. C
  2773. C       PHYSICAL
  2774. C
  2775. 700     CONTINUE
  2776.         CALL SCANVAT(0)
  2777.         IF (FATAL) RETURN
  2778.         GOTO 1
  2779. C
  2780. C       RANGE
  2781. C
  2782. 600     CALL SCANRNG
  2783.         IF (FATAL) RETURN
  2784.         GOTO 1
  2785. C
  2786. C       ENTRY
  2787. C
  2788. 900     CONTINUE
  2789.         CALL SCANMUS
  2790.         IF (FATAL) RETURN
  2791.         GOTO 1
  2792. C
  2793. C       IO
  2794. C
  2795. 1000    CONTINUE
  2796.         IO = 0
  2797.         IF (.NOT.SYMEQ('(')) THEN
  2798.           LOOP = .FALSE.
  2799.           GOTO 1002
  2800.         ELSE
  2801.           LOOP = .TRUE.
  2802.         ENDIF
  2803. 1001    CONTINUE
  2804.         CALL SCANSYM
  2805.         IF (FATAL) RETURN
  2806.         IF (SYMEQ(')')) GOTO 1003
  2807. 1002    CONTINUE
  2808.         IF (UPSYMEQ('IN')) THEN
  2809.           IO = IO.OR.1
  2810.         ELSEIF (UPSYMEQ('OUT')) THEN
  2811.           IO = IO.OR.2
  2812.         ELSE
  2813.           CALL EXPECT('IN ^O^R OUT','IO=')
  2814.           RETURN
  2815.         ENDIF
  2816.         IF (LOOP) GOTO 1001
  2817. 1003    CONTINUE
  2818.         IF (IO.EQ.3.OR.IO.EQ.0) GOTO 1
  2819.         CALL NEWVAT
  2820.         IF (FATAL) RETURN
  2821.         VAIO(NVAR) = IO
  2822.         ATIO(NATR) = VAIO(NVAR)
  2823.         GOTO 1
  2824. C
  2825. C         HELP
  2826. C
  2827. 1100    CONTINUE
  2828.         IF (SYMTP.NE.'S') THEN
  2829.           CALL EXPECT('^S^T^R^I^N^G','HELP')
  2830.           RETURN
  2831.         ENDIF
  2832.         SAVV = NVAL + 1
  2833.         SL = MIN(159,SL)
  2834.         CALL COPYSYM
  2835.         IF (FATAL) RETURN
  2836.         VARH(NVAR) = SAVV
  2837.         MSGL = MAX(MSGL,SL)
  2838.         MSGX = MIN(39,80-MSGL)
  2839.         GOTO 1
  2840.         END
  2841. C-------------------------------------------------------------------
  2842. C*      SCANVAT - SCAN VAR ATTRIBUTE
  2843. C
  2844. C       ENTRY   LOG=1 IF LOGICAL ATTRIBUTES, 0 IF PHYSICAL
  2845. C
  2846.         SUBROUTINE SCANVAT(LOG)
  2847. *CALL   COMFPAN
  2848.         INTEGER LOG
  2849.         CALL NEWVAT
  2850.         IF (FATAL) RETURN
  2851.         CALL SCANLPA(LOG)
  2852.         END
  2853. C-------------------------------------------------------------------
  2854. C*      SCANVIO - SCAN VAR IN OR OUT
  2855. C
  2856. C       ENTRY   IO = 1=IN ONLY, 2=OUT ONLY
  2857. C
  2858.         SUBROUTINE SCANVIO(IO)
  2859. *CALL   COMFPAN
  2860.         INTEGER IO
  2861.         CALL SCANSYM
  2862.         IF (FATAL) RETURN
  2863.         IF (UPSYMEQ('ONLY')) THEN
  2864.           CALL SCANSYM
  2865.           IF (FATAL) RETURN
  2866.         ENDIF
  2867.         END
  2868. C-------------------------------------------------------------------
  2869. C*      SCANVKS - SCAN VAR KEYWORDS
  2870. C
  2871. C       EXIT    I=KEYWORD ORDINAL OR 0 IF NOT
  2872. C               CURRENT SYM ADVANCED PAST KEYWORD= IF I.NE.0
  2873. C
  2874.         SUBROUTINE SCANVKS(I)
  2875. *CALL   COMFPAN
  2876.         INTEGER I
  2877.         I = 0
  2878.         IF (.NOT.ZEQNEXT()) RETURN
  2879.         IF (UPSYMEQ('NAME').OR.UPSYMEQ('N')) THEN
  2880.           I = 1
  2881.         ELSEIF (UPSYMEQ('TYPE').OR.UPSYMEQ('T')) THEN
  2882.           I = 2
  2883.         ELSEIF (UPSYMEQ('VALUE').OR.UPSYMEQ('V')) THEN
  2884.           I = 3
  2885.         ELSEIF (UPSYMEQ('FORMAT').OR.UPSYMEQ('F')) THEN
  2886.           I = 4
  2887.         ELSEIF (UPSYMEQ('MATCH').OR.UPSYMEQ('M')) THEN
  2888.           I = 5
  2889.         ELSEIF (UPSYMEQ('RANGE').OR.UPSYMEQ('R')) THEN
  2890.           I = 6
  2891.         ELSEIF (UPSYMEQ('PHYSICAL').OR.UPSYMEQ('P')) THEN
  2892.           I = 7
  2893.         ELSEIF (UPSYMEQ('LOGICAL').OR.UPSYMEQ('L')) THEN
  2894.           I = 8
  2895.         ELSEIF (UPSYMEQ('ENTRY').OR.UPSYMEQ('E')) THEN
  2896.           I = 9
  2897.         ELSEIF (UPSYMEQ('IO').OR.UPSYMEQ('I')) THEN
  2898.           I = 10
  2899.         ELSEIF (UPSYMEQ('HELP').OR.UPSYMEQ('H')) THEN
  2900.           I = 11
  2901.         ENDIF
  2902.         IF (I.EQ.0) THEN
  2903.           CALL ERROR('U^N^K^N^O^W^N ^K^E^Y^W^O^R^D')
  2904.           RETURN
  2905.         ELSE
  2906.           CALL SKIPTWO
  2907.         ENDIF
  2908.         END
  2909. C-------------------------------------------------------------------
  2910. C       SETATR - SET ATTRIBUTE
  2911. C
  2912. C       ENTRY   LP = 1=LOGICAL, 0=PHYSICAL
  2913. C               I = 0,1,2,... PARALLEL USE IN CHEKATR
  2914. C
  2915.         SUBROUTINE SETATR(LP,I)
  2916. *CALL   COMFPAN
  2917.         INTEGER LP, I
  2918. C       PRINT 56, LP, I
  2919. 56      FORMAT('SETATR, LP=',I1,' I=',I2)
  2920.         ATRLP(NATR) = CHAR(LP + ICHAR('0'))
  2921.         IF (I .EQ. 0) THEN
  2922.           ATTP(NATR) = I
  2923.           RETURN
  2924.         ENDIF
  2925.         GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), I
  2926.         RETURN
  2927. 1       CONTINUE
  2928. 2       CONTINUE
  2929. 3       CONTINUE
  2930. 4       CONTINUE
  2931. 5       CONTINUE
  2932.         ATTP(NATR) = I
  2933.         RETURN
  2934. 6       IF (LP.EQ.0) THEN
  2935.           ATRBL(NATR) = '1'
  2936.         ELSE
  2937.           ATTP(NATR) = I
  2938.         ENDIF
  2939.         RETURN
  2940. 7       IF (LP.EQ.0) THEN
  2941.           ATRIV(NATR) = '1'
  2942.         ELSE
  2943.           ATTP(NATR) = I
  2944.         ENDIF
  2945.         RETURN
  2946. 8       IF (LP.EQ.0) THEN
  2947.           ATRUL(NATR) = '1'
  2948.         ELSE
  2949.           ATTP(NATR) = I
  2950.         ENDIF
  2951.         RETURN
  2952. 9       IF (LP.EQ.0) THEN
  2953.           ATRAI(NATR) = '1'
  2954.         ELSE
  2955.           ATTP(NATR) = I
  2956.         ENDIF
  2957.         RETURN
  2958. 10      CONTINUE
  2959. 11      CONTINUE
  2960.         ATTP(NATR) = I
  2961.         RETURN
  2962. 12      CONTINUE
  2963. 13      CONTINUE
  2964. 14      CONTINUE
  2965. 15      CONTINUE
  2966. 16      CONTINUE
  2967. 17      CONTINUE
  2968.         RETURN
  2969.         END
  2970. C-------------------------------------------------------------------
  2971. C*      SETVARD - SET VARIABLE DEFAULT VALUE
  2972. C
  2973.         SUBROUTINE SETVARD
  2974. *CALL   COMFPAN
  2975.         INTEGER SAVV
  2976.         IF ((SYMTP.EQ.'S'.AND.VART(NVAR).EQ.VTC).OR.
  2977.      A      (SYMTP.EQ.'N'.AND.VART(NVAR).EQ.VTN).OR.
  2978.      B      (SYMTP.EQ.'R'.AND.VART(NVAR).EQ.VTR)) THEN
  2979.           IF (SYMTP.EQ.'I') THEN
  2980.             CALL EXPECT('^C^O^N^S^T^A^N^T','=')
  2981.             RETURN
  2982.           ENDIF
  2983.           SAVV = NVAL + 1
  2984.           CALL COPYSYM
  2985.           IF (FATAL) RETURN
  2986.           VARD(NVAR) = SAVV
  2987.         ELSE
  2988.           CALL ERROR('V^A^L^U^E ^T^Y^P^E ^M^I^S^M^A^T^C^H')
  2989.         ENDIF
  2990.         END
  2991. C-------------------------------------------------------------------
  2992. C*      SETVARN - SET VAR NAME IN ARRAY
  2993. C
  2994.         SUBROUTINE SETVARN
  2995. *CALL   COMFPAN
  2996.         CHARACTER*7 NAME
  2997.         CHARACTER*40 ES
  2998.         CALL NEWVAR
  2999.         IF (FATAL) RETURN
  3000.         NAME = STRGD(1:MIN(SL,7))
  3001.         VARNM(NVAR) = NAME
  3002.         I = 1
  3003. 1       IF (VARNM(I).NE.NAME) THEN
  3004.           I = I + 1
  3005.           GOTO 1
  3006.         ENDIF
  3007.         IF (I.NE.NVAR) THEN
  3008.           CALL ERROR('VAR ^D^E^C^L^A^R^E^D ^T^W^I^C^E')
  3009.           NVAR = NVAR - 1
  3010.         ENDIF
  3011.         END
  3012. C-------------------------------------------------------------------
  3013. C*      SKIPHED - SKIP TO HEAD
  3014. C
  3015.         SUBROUTINE SKIPHED
  3016. *CALL   COMFPAN
  3017. 1       CONTINUE
  3018.         CALL CHEKHED(I)
  3019.         IF (I.NE.0) RETURN
  3020.         CALL SCANSYM
  3021.         GOTO 1
  3022.         END
  3023. C-------------------------------------------------------------------
  3024. C*      SKIPTWO - SKIP TWO SYMBOLS
  3025. C
  3026.         SUBROUTINE SKIPTWO
  3027. *CALL   COMFPAN
  3028.         CALL SCANSYM
  3029.         IF (FATAL) RETURN
  3030.         CALL SCANSYM
  3031.         END
  3032. C-------------------------------------------------------------------
  3033. C*      SLEN - STRING LENGTH (INTEGER)
  3034. C
  3035.       FUNCTION SLEN(S,L)
  3036. *CALL   COMFPAN
  3037.       INTEGER L
  3038.       CHARACTER*(*) S
  3039.       CHARACTER*1 C
  3040.       I = 1
  3041.       J = 0
  3042. 1     CONTINUE
  3043.       C = S(I:I)
  3044.       IF (C.EQ.'@'.OR.C.EQ.'^') THEN
  3045.         I = I + 1
  3046.       ENDIF
  3047.       J = J + 1
  3048.       I = I + 1
  3049.       IF (I.LE.L) GOTO 1
  3050.       SLEN = J
  3051.       END
  3052. C-------------------------------------------------------------------
  3053. C*      SPP - SCAN PROGRAM PARAMETERS
  3054. C
  3055.         SUBROUTINE SPP
  3056. *CALL   COMFPAN
  3057. *                            GETPARM KEYWORD PARAMETER
  3058.         CHARACTER*7 KEYWORD
  3059. *                            GETPARM RETURN VALUE
  3060.         CHARACTER*7 VALUE
  3061. *                            FILE NAME OF PANEL
  3062.         CHARACTER*7 PANEL
  3063. *                            LIST FILE NAME
  3064.         CHARACTER*7 LIST
  3065. *                            CAPSULE SOURCE FILE NAME
  3066.         CHARACTER*7 COMPASS
  3067. *                            NULL FILE FLAG
  3068.         LOGICAL  NULLFIL
  3069.         DATA  PANEL   / 'PANEL' /
  3070.         DATA  LIST    / 'OUTPUT' /
  3071.         DATA  COMPASS / 'COMPASS' /
  3072.         DATA  NULLFIL / .FALSE. /
  3073.  
  3074. * GET PARAMETERS FROM EXECUTION STATEMENT.
  3075.  
  3076. 1       CALL GETPARM(KEYWORD,VALUE,I)
  3077.         IF (I.EQ.-1) THEN
  3078.           OPEN(1,ERR=10,FILE=PANEL,STATUS='OLD',RECL=266)
  3079.           IF (.NOT.NULLFIL) THEN
  3080.             OPEN(2,ERR=20,FILE=LIST,STATUS='UNKNOWN',RECL=266)
  3081.           ELSE
  3082.             OPEN(2,ERR=20,STATUS='SCRATCH',RECL=266)
  3083.           ENDIF
  3084.           OPEN(3,ERR=30,FILE=COMPASS,STATUS='UNKNOWN',RECL=80)
  3085.           REWIND 1
  3086.           PNAME = PANEL
  3087.           REWIND 2
  3088.           REWIND 3
  3089.           RETURN
  3090. 10        CALL QUITS('CAN''T OPEN FILE '//PANEL)
  3091. 20        CALL QUITS('CAN''T OPEN FILE '//LIST)
  3092. 30        CALL QUITS('CAN''T OPEN FILE '//COMPASS)
  3093.         ENDIF
  3094.         IF (KEYWORD.EQ.'I') THEN
  3095.           IF (I.EQ.0) PANEL = VALUE
  3096.           PNAME = PANEL
  3097.           GOTO 1
  3098.         ELSE IF (KEYWORD.EQ.'L') THEN
  3099.           IF (I.EQ.0) THEN
  3100.             IF (VALUE .EQ. '0') THEN
  3101.               NULLFIL = .TRUE.
  3102.             ELSE
  3103.               LIST = VALUE
  3104.             ENDIF
  3105.           ENDIF
  3106.           GOTO 1
  3107.         ELSE IF (KEYWORD.EQ.'C') THEN
  3108.           IF (I.EQ.0) COMPASS = VALUE
  3109.           GOTO 1
  3110.         ELSE
  3111.           CALL QUITS('UNRECOGNIZED PARAMETER '//KEYWORD)
  3112.         ENDIF
  3113.         END
  3114. C-------------------------------------------------------------------
  3115. C*      SYMEQ - SYMBOL EQUAL TO ARGUMENT
  3116. C
  3117. C       ENTRY
  3118. C               S = SINGLE DISPLAY CODE CHAR TO COMPARE TO SYMBOL
  3119. C
  3120.         LOGICAL FUNCTION SYMEQ(S)
  3121. *CALL   COMFPAN
  3122.         CHARACTER*(1) S
  3123.         SYMEQ = X612TA(ICHAR(S)).EQ.IMAG(SI,1).AND.SL.EQ.1
  3124.         END
  3125. C-------------------------------------------------------------------
  3126. C*      UPSYMEQ - .TRUE. IFF UPPER CASE OF CURRENT SYM .EQ. S
  3127. C
  3128.         LOGICAL FUNCTION UPSYMEQ(S)
  3129. *CALL   COMFPAN
  3130.         CHARACTER*(*) S
  3131.         J = 0
  3132.         UPSYMEQ = .FALSE.
  3133.         IF (SYMTP.EQ.'I'.AND.LEN(S).EQ.SL.AND.S.EQ.STRGD(1:SL))
  3134.      A      UPSYMEQ = .TRUE.
  3135.         END
  3136. C-------------------------------------------------------------------
  3137. C*      VFDN - VFD NUMBER
  3138. C
  3139.         SUBROUTINE VFDN(S,N)
  3140. *CALL   COMFPAN
  3141.         CHARACTER*(*) S
  3142.         INTEGER N
  3143.         IF (N.LT.0) THEN
  3144.           WRITE(3,200) S, -N
  3145. 200       FORMAT(T10,'VFD',T16,A,'-',I4.4)
  3146.         ELSE
  3147.           WRITE(3,100) S, N
  3148. 100       FORMAT(T10,'VFD',T16,A, I4.4)
  3149.         ENDIF
  3150.         END
  3151. C-------------------------------------------------------------------
  3152. C*      VFDIF - VFD IF B TRUE
  3153. C
  3154.       SUBROUTINE VFDIF(S1,B,S2)
  3155. *CALL   COMFPAN
  3156.       CHARACTER*(*) S1,S2
  3157.       CHARACTER*40 S
  3158.       IF (B.NE.0) THEN
  3159.         S = S1//S2
  3160.         CALL VFD(S)
  3161.       ELSE
  3162.         S = S1//'0'
  3163.         CALL VFD(S)
  3164.       ENDIF
  3165.       END
  3166. C-------------------------------------------------------------------
  3167. C*      VFD - VFD STRING
  3168. C
  3169.         SUBROUTINE VFD(S)
  3170. *CALL   COMFPAN
  3171.         CHARACTER*(*) S
  3172.         WRITE(3,100) S
  3173. 100     FORMAT(T10,'VFD',T16,A)
  3174.         END
  3175. C-------------------------------------------------------------------
  3176. C*      VFDO    - VFD OCTAL WORD
  3177. C
  3178.         SUBROUTINE VFDO(S,W)
  3179. *CALL   COMFPAN
  3180.         CHARACTER*(*) S
  3181.         INTEGER W
  3182.         WRITE(3,100) S, W
  3183. 100     FORMAT(T10,'VFD',T16,A,O20,'B')
  3184.         END
  3185. C-------------------------------------------------------------------
  3186. C*      VFDO2 - VFD INTEGER AS OCTAL 2
  3187. C
  3188.         SUBROUTINE VFDO2(S,I)
  3189. *CALL   COMFPAN
  3190.         CHARACTER*(*) S
  3191.         INTEGER I
  3192.         WRITE(3,100) S, I
  3193. 100     FORMAT(T10,'VFD',T16,A,O2)
  3194.         END
  3195. C-------------------------------------------------------------------
  3196. C*      VFDB - VFD LOGICAL (1 0R 0)
  3197. C
  3198.         SUBROUTINE VFDB(B)
  3199. *CALL   COMFPAN
  3200.         INTEGER B
  3201.         IF (B.NE.0) THEN
  3202.           CALL VFD('1/1')
  3203.         ELSE
  3204.           CALL VFD('1/0')
  3205.         ENDIF
  3206.         END
  3207. C*      XLINE - XLATE LINE FROM 6/12 TO ASCII
  3208. C
  3209.         SUBROUTINE XLINE(LNO)
  3210. *CALL   COMFPAN
  3211.         INTEGER LNO
  3212.         N = 0
  3213.         DO 200 I = 1,MCOL
  3214.           N = N + 1
  3215.           J = 0
  3216.           IF (LINE(N:N).EQ.'^') THEN
  3217.             J = Z"40"
  3218.             N = N + 1
  3219.           ELSEIF (LINE(N:N).EQ.'@') THEN
  3220.             J = Z"80"
  3221.             N = N + 1
  3222.           ENDIF
  3223.           IMAG(I,LNO) = X612TA(J + ICHAR(LINE(N:N)))
  3224. 200     CONTINUE
  3225.         IMAG(MCOL+1,LNO) = 0
  3226.         END
  3227. C-------------------------------------------------------------------
  3228. C*      ZEQNEXT - TRUE IF = NEXT CHARACTER ON SAME LINE
  3229. C
  3230.         LOGICAL FUNCTION ZEQNEXT()
  3231. *CALL   COMFPAN
  3232.         J = SJ
  3233. 1       IF (IMAG(J,1).EQ.ZSP) THEN
  3234.           IF (J.LE.MCOL) THEN
  3235.             J = J + 1
  3236.             GOTO 1
  3237.           ENDIF
  3238.         ENDIF
  3239.         ZEQNEXT = IMAG(J,1).EQ.ZEQ
  3240.         END
cdc/nos2.source/opl871/panel.txt · Last modified: 2023/08/05 17:24 by Site Administrator