C-------------------------------------------------------------------
C* PANEL DESIGN UTILITY
C
C COPYRIGHT CONTROL DATA SYSTEMS INC. 1992.
C
PROGRAM PANEL(PANEL=/266,OUTPUT=/266,TAPE1=PANEL)
*CALL COMFPAN
C
C SCAN PARAMETERS
C
CALL CSETA
CALL SPP
WRITE(2,'(A/)') '1 P^A^N^E^L D^E^F^I^N^I^T^I^O^N ' //
A 'U^T^I^L^I^T^Y F^I^L^E ' // PNAME
C
C SCAN PANEL DEFINITIONS
C
CALL READL1
IF (ISA(IMAG(1,1))) THEN
CALL SCANSYM
1 IF (IMAG(SJ,1).EQ.ZSP.AND.SJ.LE.MCOL) THEN
SJ = SJ + 1
GOTO 1
ENDIF
IF (SJ.GT.MCOL) THEN
PNAME = STRGD(1:SL)
CALL READL1
ENDIF
ENDIF
2 IF (IMAG(SJ,1).EQ.ZSP.AND.SJ.LE.MCOL) THEN
SJ = SJ + 1
GOTO 2
ENDIF
IF (IMAG(SJ,1).EQ.ZLB) THEN
CLDC = ZRB
ELSE IF (IMAG(SJ,1).EQ.ZOB) THEN
CLDC = ZCB
ELSE IF (IMAG(SJ,1).EQ.ZLT) THEN
CLDC = ZGT
ELSE
CALL QUIT('OPENING DELIMITER.')
ENDIF
INDEF = .TRUE.
SJ = SJ + 1
CALL SCANDEF
INDEF = .FALSE.
IF (ABEND) CALL QUIT('DECLARATIONS')
C
C SCAN PANEL IMAGE
C
CALL RPI
CALL SCANIMG
IF (FATAL) CALL QUIT('SCREEN IMAGE')
C
C WRITE PANEL DESCRIPTION
C
IF (.NOT.FATAL) THEN
CALL GPR
ENDIF
REWIND 1
REWIND 2
REWIND 3
C
END
C-------------------------------------------------------------------
C* BLOCK DATA FOR PANEL
C
BLOCK DATA
*CALL COMFPAN
DATA PNAME /'TEST '/
DATA BLANK/' '/
DATA IMAG /10304*0/, NROW /0/, NCOL/0/
DATA VERS,MSGL,MSGX,MSGY,CLDC/0,20,39,0,0/
DATA VERS,MSGL,MSGX,MSGY/1,20,39,0/
DATA BLKA,ERBW,ERAR,WRIB/0,1,0,0/
DATA FATAL /.FALSE./, INDEF /.FALSE./, ENDFILE /.FALSE./
DATA ABEND /.FALSE./
C
C ATTRIBUTE DATA, LOGICAL FLAG, INPUT/OUTPUT, ORDINAL, NUMBER
C
DATA ATRLP /'1','1','1',61*'0'/
DATA ATIO /2,0,2,61*2/
DATA ATTP /4,0,1,61*0/
DATA NATR /3/
C
C ATTRIBUTE DATA, ALTERNATE, BLINK, INVERSE AND UNDERLINE
C
DATA ATRAI /MATR*'0'/
DATA ATRBL /MATR*'0'/
DATA ATRIV /MATR*'0'/
DATA ATRUL /MATR*'0'/
C
C ATTRIBUTE DATA, BRACKET ID, CHAR. END, CHAR. START, LINE
C WEIGHT AND SPECIAL CHARACTER
C
DATA ATBI /MATR*0/
DATA ATCE /MATR*0/
DATA ATCS /MATR*0/
DATA ATLW /MATR*0/
DATA ATSC /MATR*0/
DATA SPCH /128*0/
C
DATA NBOX /0/
DATA IBOX /0/
DATA CORS /0/
C CORNER TYPES
C
C D U R L TYPE ORDINAL
C 0 0 0 0 CROSS 10
C 0 0 0 1 HL 0
C 0 0 1 0 HL 0
C 0 0 1 1 HL 0
C 0 1 0 0 VL 1
C 0 1 0 1 LU 5
C 0 1 1 0 UR 4
C 0 1 1 1 LUR 7
C 1 0 0 0 VL 1
C 1 0 0 1 LD 3
C 1 0 1 0 RD 2
C 1 0 1 1 LRD(T) 6
C 1 1 0 0 VL 1
C 1 1 0 1 LUD 9
C 1 1 1 0 URD 8
C 1 1 1 1 CROSS 10
C
DATA CORO/10,0,0,0,1,5,4,7,1,3,2,6,1,9,8,10/
C
DATA NCON /0/
C
DATA NFIE /0/
C
DATA NFUN, FUNA, FUNG, FUNK /0, MFUN*0, MFUN*0, MFUN*0/
C
DATA SYMTP /' '/
DATA STRGD /' '/
DATA SI, SJ /1,1/
DATA SL, STRG, SINT, SIGN /0, MCOL*0, 0, 0/
DATA SREALV /0.0/
C
DATA TABNM /8*'*'/
DATA NTAB /0/
C
DATA VARNM /256*' '/
DATA TYPES /'CHAR', 'INT', 'REAL'/
DATA NVAR /0/
DATA NVAF /0/
DATA VDCO /0/
DATA NVAL /0/
END
C-------------------------------------------------------------------
C* BLOCK - GENERATE BLOCK COMMENTS
C
SUBROUTINE BLOCK(S)
CHARACTER*(*) S
WRITE (3,100) S
100 FORMAT('*'/'*', T10, A/'*')
END
C-------------------------------------------------------------------
C* BSS - BSS 0
C
SUBROUTINE BSS
*CALL COMFPAN
WRITE(3,100)
100 FORMAT(T10,'BSS',T16,'0')
END
C-------------------------------------------------------------------
C* CHEKATR - CHECK ATTRIBUTE
C
C EXIT LP= 1=LOGICAL, 0=PHYSICAL, 3=ERROR
C I = 0,1,2,... PARALLEL USE IN SETATR
C
SUBROUTINE CHEKATR(LP,I)
*CALL COMFPAN
LP = 1
IF (UPSYMEQ('ITEXT').OR.UPSYMEQ('INPUT')) THEN
I = 0
ELSEIF (UPSYMEQ('TEXT')) THEN
I = 1
ELSEIF (UPSYMEQ('ITALIC')) THEN
I = 2
ELSEIF (UPSYMEQ('TITLE')) THEN
I = 3
ELSEIF (UPSYMEQ('MESSAGE')) THEN
I = 4
ELSEIF (UPSYMEQ('ERROR')) THEN
I = 5
ELSEIF (UPSYMEQ('ITEXT2').OR.UPSYMEQ('INPUT2')) THEN
I = 6
ELSEIF (UPSYMEQ('TEXT2')) THEN
I = 7
ELSEIF (UPSYMEQ('ITALIC2')) THEN
I = 8
ELSEIF (UPSYMEQ('TITLE2')) THEN
I = 9
ELSEIF (UPSYMEQ('MESSAGE2')) THEN
I = 10
ELSEIF (UPSYMEQ('ERROR2')) THEN
I = 11
ELSE
LP = 0
IF (UPSYMEQ('BLINK')) THEN
I = 6
ELSEIF (UPSYMEQ('INVERSE').OR.UPSYMEQ('INV')) THEN
I = 7
ELSEIF (UPSYMEQ('UNDERLINE').OR.UPSYMEQ('UND')
A .OR.UPSYMEQ('UNDERSCORE')) THEN
I = 8
ELSEIF (UPSYMEQ('ALTERNATE').OR.UPSYMEQ('ALT')) THEN
I = 9
ELSE
LP = 3
ENDIF
ENDIF
END
C-------------------------------------------------------------------
C* CHEKHED - CHECK FOR SYNTAX ELEMENT
C EXIT - VAR I = 1
C KEY I = 2
C ATTR I = 3
C BRACKET I = 4
C BOX I = 5
C TABLE I = 6
C TABLE END I = 7
C PANEL I = 8
C SFATTR I = 9
C I = 0 IF NONE
C
SUBROUTINE CHEKHED(I)
*CALL COMFPAN
INTEGER I
I = 0
1 IF (SYMEQ(';')) THEN
CALL SCANSYM
IF (FATAL) RETURN
GOTO 1
ENDIF
IF(UPSYMEQ('VAR')) THEN
I = 1
ELSE IF(UPSYMEQ('KEY')) THEN
I = 2
ELSE IF(UPSYMEQ('ATTR')) THEN
I = 3
ELSE IF(IMAG(SI,1).EQ.CLDC) THEN
I = 4
ELSE IF(UPSYMEQ('BOX')) THEN
I = 5
ELSE IF(UPSYMEQ('TABLE')) THEN
I = 6
ELSE IF(UPSYMEQ('TABLEND')) THEN
I = 7
ELSE IF(UPSYMEQ('PANEL')) THEN
I = 8
ELSE IF(UPSYMEQ('SFATTR')) THEN
I = 9
ENDIF
END
C---------------------------------------------------------------------
C* CHEKKEY - CHECK KEY NAME
C
C EXIT G= 1=FUNCTION
C 2=GENERIC
C N=KEY NUMBER
C
SUBROUTINE CHEKKEY(G,N)
*CALL COMFPAN
INTEGER G, N
LOGICAL SHIFT
SHIFT = .FALSE.
G = 1
IF (UPSYMEQ('S').OR.UPSYMEQ('SHIFT')) THEN
SHIFT = .TRUE.
CALL SCANSYM
IF (FATAL) RETURN
ENDIF
IF (UPSYMEQ('F1')) THEN
N = 1
ELSEIF (UPSYMEQ('F2')) THEN
N = 2
ELSEIF (UPSYMEQ('F3')) THEN
N = 3
ELSEIF (UPSYMEQ('F4')) THEN
N = 4
ELSEIF (UPSYMEQ('F5')) THEN
N = 5
ELSEIF (UPSYMEQ('F6')) THEN
N = 6
ELSEIF (UPSYMEQ('F7')) THEN
N = 7
ELSEIF (UPSYMEQ('F8')) THEN
N = 8
ELSEIF (UPSYMEQ('F9')) THEN
N = 9
ELSEIF (UPSYMEQ('F10')) THEN
N = 10
ELSEIF (UPSYMEQ('F11')) THEN
N = 11
ELSEIF (UPSYMEQ('F12')) THEN
N = 12
ELSEIF (UPSYMEQ('F13')) THEN
N = 13
ELSEIF (UPSYMEQ('F14')) THEN
N = 14
ELSEIF (UPSYMEQ('F15')) THEN
N = 15
ELSEIF (UPSYMEQ('F16')) THEN
N = 16
ELSEIF (UPSYMEQ('F17')) THEN
N = 17
ELSEIF (UPSYMEQ('F18')) THEN
N = 18
ELSEIF (UPSYMEQ('F19')) THEN
N = 19
ELSEIF (UPSYMEQ('F20')) THEN
N = 20
ELSEIF (UPSYMEQ('F21')) THEN
N = 21
ELSEIF (UPSYMEQ('F22')) THEN
N = 22
ELSEIF (UPSYMEQ('F23')) THEN
N = 23
ELSEIF (UPSYMEQ('F24')) THEN
N = 24
ELSE
G = 2
IF (UPSYMEQ('NEXT')) THEN
N = 1
ELSEIF (UPSYMEQ('BACK')) THEN
N = 2
ELSEIF (UPSYMEQ('HELP')) THEN
N = 3
ELSEIF (UPSYMEQ('STOP')) THEN
N = 4
ELSEIF (UPSYMEQ('DOWN')) THEN
N = 5
ELSEIF (UPSYMEQ('UP')) THEN
N = 6
ELSEIF (UPSYMEQ('FWD')) THEN
N = 7
ELSEIF (UPSYMEQ('BKW')) THEN
N = 8
ELSEIF (UPSYMEQ('EDIT')) THEN
N = 9
ELSEIF (UPSYMEQ('DATA')) THEN
N = 10
ELSE
G = 0
ENDIF
ENDIF
IF (SHIFT) THEN
IF (G.EQ.0) THEN
CALL ERROR('SHIFT ^N^O^T ^A^L^L^O^W^E^D')
RETURN
ENDIF
N = -N
ENDIF
END
C---------------------------------------------------------------------
C* CHEKPIC - CHECK IF FILL, ENTER, OR KNOW
C
C* CHEKPIC - CHECK IF X, A, 9, N, E, $, Y , M OR D.
C RETURN FORMAT ORDINAL OR 0 IF NONE.
C
SUBROUTINE CHEKPIC(I)
*CALL COMFPAN
INTEGER I
IF (UPSYMEQ('X')) THEN
I = VPX
ELSE IF (UPSYMEQ('A')) THEN
I = VPA
ELSE IF (SYMEQ('9')) THEN
I = VP9
ELSE IF (UPSYMEQ('N')) THEN
I = VPN
ELSE IF (UPSYMEQ('E')) THEN
I = VPE
ELSE IF (SYMEQ('$')) THEN
I = VPC
ELSE IF (UPSYMEQ('Y') .OR. UPSYMEQ('YMD')) THEN
I = VPY
ELSE IF (UPSYMEQ('M') .OR. UPSYMEQ('MDY')) THEN
I = VPM
ELSE IF (UPSYMEQ('D') .OR. UPSYMEQ('DMY')) THEN
I = VPD
ELSE
I = 0
ENDIF
END
C-------------------------------------------------------------------
C* CLEN - RETURN LENGTH OF NAME
C
C ENTRY S=STRING
C 7 CHARACTERS OR LESS
C
INTEGER FUNCTION CLEN(S)
CHARACTER*(*) S
I = 7
1 IF (S(I:I).EQ.' ') THEN
IF (I.GT.1) THEN
I = I - 1
GOTO 1
ENDIF
ENDIF
CLEN = I
END
C-------------------------------------------------------------------
C* COMMENT - OUTPUT A COMMENT
C
SUBROUTINE COMMENT(S)
*CALL COMFPAN
CHARACTER*(*) S
WRITE(3,100) S
100 FORMAT('*',A)
END
C-------------------------------------------------------------------
C* COPYSYM - COPY SYMBOL TO VALIDATION TABLE
C
SUBROUTINE COPYSYM
*CALL COMFPAN
IF (SYMTP.EQ.'S') THEN
IF (NVAL+SL.GE.MVAL) THEN
CALL ERROR('VALIDATION TABLE OVERFLOW')
RETURN
ENDIF
NVAL = NVAL + 1
VVAL(NVAL) = SL
DO 100 I = 1, SL
NVAL = NVAL + 1
VVAL(NVAL) = STRG(I)
100 CONTINUE
ELSE
IF (NVAL+SJ-SI.GE.MVAL) THEN
CALL ERROR('VALIDATION TABLE OVERFLOW')
RETURN
ENDIF
NVAL = NVAL + 1
VVAL(NVAL) = SJ - SI
DO 200 I = SI, SJ - 1
NVAL = NVAL + 1
VVAL(NVAL) = IMAG(I,1)
200 CONTINUE
ENDIF
END
C-------------------------------------------------------------------
C* COPYVAR - INITIALIZE VARIABLE TO SAME AS VARIABLE I
C
C I - INDEX OF VARIABLE TO COPY
C J - ROW NUMBER
C
C
SUBROUTINE COPYVAR(I,J)
*CALL COMFPAN
INTEGER I, J
IF (NVAR.EQ.MVAR) THEN
CALL ERRORN(MVAR,'^V^A^R^I^A^B^L^E^S')
RETURN
ENDIF
NVAR = NVAR + 1
VTAB(NVAR) = VTAB(I)
VAIO(NVAR) = VAIO(I)
VARL(NVAR) = VARL(I)
VARV(NVAR) = VARV(I)
VART(NVAR) = VART(I)
VARM(NVAR) = VARM(I)
VARC(NVAR) = VARC(I)
VARP(NVAR) = VARP(I)
VAVT(NVAR) = VAVT(I)
VARH(NVAR) = VARH(I)
VARD(NVAR) = VARD(I)
VARA(NVAR) = VARA(I)
VARF(NVAR) = VARF(I)
VARR(NVAR) = J
VARNM(NVAR) = VARNM(I)
END
C-------------------------------------------------------------------
C* CORGEN - CORNER GENERATION
C
C ENTRY
C I,J=POSITION OF CORNER
C T= TYPE OF CORNER
C
SUBROUTINE CORGEN(I,J,T)
*CALL COMFPAN
INTEGER I,J,T
CALL NEWLC(I,J,1,T)
NCOL = MAX(NCOL,I)
END
C-------------------------------------------------------------------
C* CORMOVH - MOVE FROM CORNER TO FOLLOW A HORIZONTAL LINE
C
C ENTRY
C I,J=POS OF CORNER
C II=INCREMENT TO MOVE
C
SUBROUTINE CORMOVH(I,J,II)
*CALL COMFPAN
INTEGER I,J,II
INTEGER IS
IS = I
100 IS = IS + II
IF (IS.GT.0.AND.IS.LE.MCOL) THEN
IF (ISLINH(IMAG(IS,J))) GOTO 100
IF (ISCOR(IMAG(IS,J))) CALL CORSTAK(IS,J)
ENDIF
IF (IS.NE.I+II) THEN
C HAD SOME LINE
CALL NEWHL(MIN(I+II,IS-II),J,IABS(IS-I)-1)
ENDIF
END
C-------------------------------------------------------------------
C* CORMOVV - MOVE FROM CORNER TO FOLLOW A VERTICAL LINE
C
C ENTRY
C I,J=POS OF CORNER
C JI=INCREMENT TO MOVE
C
SUBROUTINE CORMOVV(I,J,JI)
*CALL COMFPAN
INTEGER I,J,JI
INTEGER JS
JS = J
100 JS = JS + JI
IF (JS.GT.0.AND.JS.LE.MROW) THEN
IF (ISLINV(IMAG(I,JS))) GOTO 100
IF (ISCOR(IMAG(I,JS))) CALL CORSTAK(I,JS)
ENDIF
IF (JS.NE.J+JI) THEN
C HAD SOME LINE
CALL NEWVL(I,MIN(J+JI,JS-JI),IABS(JS-J)-1)
ENDIF
END
C-------------------------------------------------------------------
C* CORSTAK - CORNER STACK
C
C ENTRY
C I,J=POS OF CORNER
C
SUBROUTINE CORSTAK(I,J)
*CALL COMFPAN
INTEGER I,J
INTEGER CT
C
C MAKE SURE NOT ALREADY STACKED
C
IF (IMAG(I,J).EQ.128) RETURN
IMAG(I,J) = 128
C
C MAKE SURE CAN STACK
C
IF (CORS.EQ.MCOR) THEN
CALL ERROR('B^O^X ^T^O^O ^B^I^G')
RETURN
ENDIF
C
C FIGURE OUT WHAT KIND OF CORNER
C
CT = 0
C
C LEFT
C
IF (I.GT.1) THEN
IF (ISLCH(IMAG(I-1,J))) THEN
CT = 1
ENDIF
ENDIF
C
C RIGHT
C
IF (I.LT.MCOL) THEN
IF (ISLCH(IMAG(I+1,J))) THEN
CT = CT + 2
ENDIF
ENDIF
C
C UP
C
IF (J.GT.1) THEN
IF (ISLCV(IMAG(I,J-1))) THEN
CT = CT + 4
ENDIF
ENDIF
C
C DOWN
C
IF (J.LT.NROW) THEN
IF (ISLCV(IMAG(I,J+1))) THEN
CT = CT + 8
ENDIF
ENDIF
C
C NOW STACK IT
C
CORS = CORS + 1
CORI(CORS) = I
CORJ(CORS) = J
CORT(CORS) = CORO(CT+1)
END
C-------------------------------------------------------------------
C* DOBOX - SCAN BOX FROM IMAGE
C
C ENTRY
C STARTI,J=POSITION OF BOX CORNER
C A=INDEX OF BOX
C
C THE STRATEGY IS TO SCAN THE ENTIRE "BOX", INCLUDING ANY
C CONNECTED LINES, AND REPLACE IT WITH BLANKS. NOTE THIS IS
C A LEGAL BOX (/ REPRESENTS VERTICAL BAR):
C
C +-----+ ++
C / / +-+ //
C +---+-----+ +--+--++
C / / +---+--
C ---+-++--+----+
C ++ /
C
SUBROUTINE DOBOX(STARTI,STARTJ,A)
*CALL COMFPAN
INTEGER STARTI, STARTJ, A
INTEGER I,J,T,IE,JE
INTEGER FIRSTI
FIRSTI = IBOX + 1
C
C BOX ATTRIBUTE ORDINAL TO GLOBAL *NBOX*
C
NBOX = BOXW(A)
C
C STACK FIRST CORNER
C
CORS = 0
I = STARTI
J = STARTJ
CALL CORSTAK(I,J)
IF (FATAL) RETURN
C
C UNSTACK CORNER AND SCAN IT
C
100 CONTINUE
IF (CORS.EQ.0) THEN
CALL ERASBOX(FIRSTI)
RETURN
ENDIF
I = CORI(CORS)
J = CORJ(CORS)
T = CORT(CORS)
CORS = CORS - 1
C
C GEN CORNER
C
CALL CORGEN(I,J,T)
C
C MOVE LEFT
C
CALL CORMOVH(I,J,-1)
C
C MOVE RIGHT
C
CALL CORMOVH(I,J,1)
C
C MOVE UP
C
CALL CORMOVV(I,J,-1)
C
C MOVE DOWN
C
CALL CORMOVV(I,J,1)
GOTO 100
END
C-------------------------------------------------------------------
C* EOP - END OF PANEL
C
SUBROUTINE EOP
*CALL COMFPAN
WRITE(3,100) PNAME
100 FORMAT('.LAST BSS 0'/
A ' END ',A)
END
C-------------------------------------------------------------------
C* ERASBOX - ERASE BOX
C
C FI - FIRST IBOX IN BOX
C
SUBROUTINE ERASBOX(FI)
*CALL COMFPAN
INTEGER FI
DO 100 I = FI, IBOX
IMAG(BOXX(I)+1,BOXY(I)+1) = ZSP
100 CONTINUE
END
C-------------------------------------------------------------------
C* ERR - ERROR
C
SUBROUTINE ERR(S)
*CALL COMFPAN
CHARACTER*(*) S
WRITE(2,'(2A)') ' PANEL INTERNAL ERROR: ',S
END
C-------------------------------------------------------------------
C* ERROR - SYNTAX ERROR MESSAGE
C
SUBROUTINE ERROR(S)
*CALL COMFPAN
CHARACTER*(*) S
IF (INDEF) THEN
IF (SI.EQ.1) THEN
WRITE(2,'('' '',A)') '!'
ELSE
WRITE(2,'('' '', 2A)') BLANK(1:SI-1), '!'
ENDIF
ENDIF
WRITE(2,1) S
1 FORMAT(' *ERROR* ',A)
FATAL = .TRUE.
END
C-------------------------------------------------------------------
C* ERRORN - MORE THAN N OF S
C
C ENTRY N=NUMBER
C S=STRING
C
SUBROUTINE ERRORN(N,S)
*CALL COMFPAN
INTEGER N
CHARACTER*(*) S
CHARACTER*80 M
IF (N.LT.10) THEN
WRITE(M,'(A,I1,2A)') ' M^O^R^E ^T^H^A^N ', N, ' ', S
ELSE IF (N.LT.100) THEN
WRITE(M,'(A,I2,2A)') ' M^O^R^E ^T^H^A^N ', N, ' ', S
ELSE
WRITE(M,'(A,I3,2A)') ' M^O^R^E ^T^H^A^N ', N, ' ', S
ENDIF
CALL ERROR (M)
END
C-------------------------------------------------------------------
C* EXPECT - EXPECT S1 AFTER S2 ERROR
C
SUBROUTINE EXPECT(S1,S2)
*CALL COMFPAN
CHARACTER*(*) S1, S2
CHARACTER*80 S
S = ' '
IF (S2(1:1).EQ.' ') THEN
S = 'E^X^P^E^C^T^I^N^G '//S1
ELSE
S = 'E^X^P^E^C^T^I^N^G '//S1//' ^A^F^T^E^R '//S2
ENDIF
CALL ERROR(S)
END
C-------------------------------------------------------------------
C* GAL - GENERATE ARRAY LIST
C
SUBROUTINE GAL
*CALL COMFPAN
CALL BLOCK('TABLE LIST')
CALL LABEL('TABL')
DO 1000 I = 1,NTAB
CALL VFD('42/0H'//TABNM(I))
CALL VFD('18/0')
CALL VFD('36/0')
CALL VFDN('8/',TABD(I))
CALL VFDN('8/',TABR(I))
CALL VFDN('8/',TABF(I))
1000 CONTINUE
IF (NTAB.GT.0) CALL VFD('60/0')
END
C-------------------------------------------------------------------
C* GAT - GENERATE ATTRIBUTE TABLE
C
SUBROUTINE GAT
*CALL COMFPAN
CALL BLOCK('ATTRIBUTE TABLE')
CALL LABEL('ATTR')
C
DO 1000 I = 1,NATR
CALL LABELN('ATR',I-1)
C LOGICAL/PHYSICAL
CALL VFD('1/'//ATRLP(I))
C PROTECT, GUARD
CALL VFDN('2/',ATIO(I))
C PHYSICAL ATTRIBUTES
IF (ATRLP(I).EQ.'0') THEN
C RESERVED
CALL VFD('5/0')
C UNDERLINE
CALL VFD('1/'//ATRUL(I))
C ALT. INTENSITY
CALL VFD('1/'//ATRAI(I))
C INVERSE VIDEO
CALL VFD('1/'//ATRIV(I))
C BLINK
CALL VFD('1/'//ATRBL(I))
C LOGICAL ATTRIBUTE
ELSE
C RESERVED
CALL VFD('3/0')
C LOGICAL ORDINAL
CALL VFDN('6/',ATTP(I))
C END OF ATTRIBUTES
ENDIF
C RESERVED
CALL VFD('15/0')
C ATTRIBUTE CHAR START
CALL VFDN('12/',ATCS(I))
C ATTRIBUTE CHAR END
CALL VFDN('12/',ATCE(I))
C SPECIAL CHARACTER
CALL VFDN('2/',ATSC(I))
C BRACKET ID
CALL VFDN('5/',ATBI(I))
C LINE WEIGHT
CALL VFDN('2/',ATLW(I))
CALL COMMENT('*')
1000 CONTINUE
END
C-------------------------------------------------------------------
C* GBL - GENERATE BOX LIST
C
SUBROUTINE GBL
*CALL COMFPAN
INTEGER I
CALL BLOCK('BOX LIST')
CALL LABEL('BOXS')
DO 2000 I = 1, IBOX
CALL VFDN('12/',BOXA(I)-1)
CALL VFDN('4/',BOXC(I))
CALL VFDN('6/',BOXY(I))
CALL VFDN('9/',BOXX(I))
CALL VFDN('9/',BOXN(I))
CALL VFD('20/0')
CALL COMMENT('*')
2000 CONTINUE
C TERMINATE BOX LIST
CALL VFD('60/0')
END
C-------------------------------------------------------------------
C* GCD - GENERATE CONSTANT DATA
C
SUBROUTINE GCD
*CALL COMFPAN
CALL BLOCK('CONSTANTS')
CALL LABEL('CONS')
DO 100 I = 1, NCON
CALL LABELN('CON',I)
CALL VFD('12/7')
CALL GST(IMAG,CONI(I)+(MCOL+1)*FIEY(CONF(I)),
A FIEL(CONF(I)),(FIEL(CONF(I))+6)/5*5-1,
B 0,O"4000")
100 CONTINUE
END
C-------------------------------------------------------------------
C* GFL - GENERATE FIELD LIST
C
SUBROUTINE GFL
*CALL COMFPAN
CALL BLOCK('FIELDS')
CALL LABEL('FIEL')
DO 100 I = 1, NFIE
C FIELD TYPE (1=VAR, 0=CONST)
CALL VFDN('1/',FIET(I))
C ATTRIBUTE ORDINAL
CALL VFDN('7/',FIEA(I))
C I/0 (0=NA, 1=OUT, 2=IN, 3=IN/OUT
C CONSTANT ALWAYS 1
IF (FIET(I).EQ.0) THEN
CALL VFD('2/1')
ELSE
CALL VFDN('2/',3-VAIO(FIEV(I)))
ENDIF
C VALUE ENTERED, VALID
CALL VFD('2/0')
C REWRITE
CALL VFD('1/1')
C ACTIVE
CALL VFD('1/1')
C RESERVED
CALL VFD('1/0')
C CONSTANT
IF (FIET(I).EQ.0) THEN
C RESERVED
CALL VFD('3/0')
C CONSTANT OFFSET
CALL VFDN('18/-START+CON',FIEV(I))
C VARIABLE
ELSE
C VARIABLE ORDINAL
CALL VFDN('8/',FIEV(I)-1)
C VAR DATA ORDINAL
CALL VFDN('13/',FIEO(I))
ENDIF
C LENGTH
CALL VFDN('9/',FIEL(I))
C LINE
CALL VFDN('6/',FIEY(I))
C COLUMN
CALL VFDN('9/',FIEX(I))
CALL COMMENT(' ')
100 CONTINUE
IF (NFIE.GT.0) CALL VFD('60/0')
END
C-------------------------------------------------------------------
C* GFT - GENERATE FUNCTION TABLE
C
SUBROUTINE GFT
*CALL COMFPAN
CALL BLOCK('FUNCTIONS')
CALL LABEL('FUNC')
DO 1000 I = 1, NFUN
CALL VFD('44/0')
CALL VFDN('9/',FUNA(I))
CALL VFDN('1/',FUNG(I))
CALL VFDN('6/',FUNK(I))
CALL COMMENT('*')
1000 CONTINUE
IF (NFUN.GT.0) CALL VFD('60/0')
END
C-------------------------------------------------------------------
C* GPE - GENERATE PANEL END
C
SUBROUTINE GPE
*CALL COMFPAN
CALL BLOCK('END OF PANEL')
CALL LABEL('LAST')
WRITE(3,100) PNAME
100 FORMAT(T10,'END',T16,A)
END
C-------------------------------------------------------------------
C* GPH - GENERATE PANEL HEADER
C
SUBROUTINE GPH
*CALL COMFPAN
C
WRITE(3,100) PNAME, PNAME(1:CLEN(PNAME)), PNAME, PNAME
100 FORMAT(T10,'IDENT',T16,A/
A T10,'LCC',T16,'GROUP(SFPANEL)'/
B T10,'LCC',T16,'CAPSULE(',A,')'/
C T10,'ENTRY',T16,A/
D A,T10,'BSS',T16,'0')
CALL BLOCK('PANEL HEADER')
CALL LABEL('START')
CALL VFD('42/0L'//PNAME)
CALL VFD('14/0')
CALL VFDB(WRIB)
CALL VFDB(ERAR)
CALL VFDB(ERBW)
CALL VFDB(BLKA)
C
CALL COMMENT(' ')
CALL VFDN('6/',NROW-1)
CALL VFD('18/LAST-START')
CALL VFDIF('18/',NFUN,'FUNC-START')
CALL VFDIF('18/',NVAR,'VARS-START')
C
CALL COMMENT(' ')
CALL VFDN('6/',VERS)
CALL VFD('18/ATTR-START')
CALL VFDIF('18/',NTAB,'TABL-START')
CALL VFDIF('18/',NFIE,'FIEL-START')
C
CALL COMMENT(' ')
CALL VFD('6/0')
CALL VFDIF('18/',NBOX,'BOXS-START')
CALL VFD('12/0')
CALL VFDN('9/',MSGL)
CALL VFDN('6/',MSGY)
CALL VFDN('9/',MSGX)
C
CALL COMMENT(' ')
N = 0
DO 200 I = 1, NFIE
IF (FIET(I).EQ.1) THEN
N = N + FIEL(I)
ENDIF
200 CONTINUE
CALL VFDN('13/',N)
NCOL = MAX(NCOL,MSGL)
CALL VFDN('9/',NCOL)
CALL VFD('38/0')
END
C-------------------------------------------------------------------
C* GPR - GENERATE PANEL RECORD
C
SUBROUTINE GPR
*CALL COMFPAN
C PANEL HEADER
CALL GPH
C VAR DATA
CALL GVD
C FIELD LIST
CALL GFL
C CONSTANTS
CALL GCD
C VARIABLES
CALL GVF
C HELP
CALL GVH
C VALIDATION
CALL GVV
C FUNCTION KEYS
CALL GFT
C ATTRIBUTES
CALL GAT
C TABLES
CALL GAL
C BOXES
CALL GBL
C END
CALL GPE
END
C-------------------------------------------------------------------
C* GST - GENERATE STRING FROM ARRAY
C
C ENTRY A = ARRAY
C J = START OF STRING
C L = ACTUAL LENGTH OF STRING
C ML= MIN AND MAX LENGTH OF STRING
C F = FILL CHAR
C IAF = CONSTANT TO ADD TO DATA (NOT FILL)
C
SUBROUTINE GST(A,J,L,ML,F,IAF)
*CALL COMFPAN
INTEGER A(1), J, L, ML, F, IAF
LEN = MIN(L,ML)
DO 100 I = 0, LEN-1
CALL VFDN('12/',A(J+I)+IAF)
100 CONTINUE
DO 200 I = LEN+1, ML
CALL VFDN('12/',F)
200 CONTINUE
END
C-------------------------------------------------------------------
C* GVD - GENERATE VAR DATA
C
SUBROUTINE GVD
*CALL COMFPAN
INTEGER N
INTEGER NULL(1)
DATA NULL/Z"20"/
CALL BLOCK('VAR DATA')
CALL LABEL('DATA')
DO 100 I = 1, NFIE
IF (FIET(I).EQ.1) THEN
C INITIAL VALUE
IF (VARD(FIEV(I)).NE.0) THEN
C CHAR LEFT JUSTIFIED
IF (VART(FIEV(I)).EQ.VTC) THEN
CALL GST(VVAL,VARD(FIEV(I))+1,
A VVAL(VARD(FIEV(I))),FIEL(I),ZSP,0)
ELSE
C NUMBERS RIGHT JUSTIFIE
N = VVAL(VARD(FIEV(I))) - FIEL(I)
IF (N.GE.0) THEN
CALL GST(VVAL,VARD(FIEV(I))+1+N,
A FIEL(I),FIEL(I),ZSP,0)
ELSE
CALL GST(NULL,1,1,-N,ZSP,0)
CALL GST(VVAL,VARD(FIEV(I))+1,
A VVAL(VARD(FIEV(I))),FIEL(I)+N,ZSP,0)
ENDIF
ENDIF
ELSE
CALL GST(NULL,1,1,FIEL(I),ZSP,0)
ENDIF
ENDIF
100 CONTINUE
END
C-------------------------------------------------------------------
C* GVF - GENERATE VARIABLE FIELDS
C
SUBROUTINE GVF
*CALL COMFPAN
CALL BLOCK('VARIABLES')
CALL LABEL('VARS')
DO 100 I = 1, NVAR
C MUST CONTAIN (A VALUE)
CALL VFDN('1/',VARC(I))
C FIELD OFFSET
CALL VFDN('9/',VARF(I))
C ROW NUMBER
CALL VFDN('8/',VARR(I))
C ARRAY ORDINAL
CALL VFDN('5/',VTAB(I))
C MUST ENTER, FILL, KNOW
CALL VFDN('3/',VARM(I))
C TYPE
CALL VFDN('2/',VART(I))
C PICTURE
CALL VFDN('8/',VARP(I))
C VALIDATION
CALL VFDN('6/',VAVT(I))
C VALIDATION OFFSET
IF (VARV(I).NE.0) THEN
CALL VFDN('18/-START+VAL',I)
ELSE
CALL VFD('18/0')
ENDIF
CALL COMMENT(' ')
C VAR NAME
CALL VFD('42/0H'//VARNM(I))
C HELP
IF (VARH(I).NE.0) THEN
CALL VFDN('18/-START+HLP',I)
ELSE
CALL VFD('18/0')
ENDIF
CALL COMMENT('*')
C
100 CONTINUE
IF (NVAR.GT.0) CALL VFD('60/0')
END
C-------------------------------------------------------------------
C* GVH - GENERATE VARIABLE HELP
C
SUBROUTINE GVH
*CALL COMFPAN
CALL BLOCK('HELP')
DO 300 I = 1, NVAR
IF (VARH(I).NE.0) THEN
L = VVAL(VARH(I))
IF (L.GT.0) THEN
CALL LABELN('HLP',I)
CALL VFD('12/7')
CALL GST(VVAL,VARH(I)+1,VVAL(VARH(I)),
A (L+6)/5*5-1,0,O"4000")
ENDIF
ENDIF
300 CONTINUE
END
C-------------------------------------------------------------------
C* GVV - GENERATE VARIABLE VALIDATION
C
SUBROUTINE GVV
*CALL COMFPAN
INTEGER L
CALL BLOCK('VALIDATION')
DO 300 I = 1, NVAR
GOTO (100,200), VAVT(I)
GOTO 300
C
C MATCH
C
100 CONTINUE
CALL LABELN('VAL',I)
J = VARV(I)
110 CONTINUE
IF (VVAL(J).LT.0) THEN
CALL VFD('60/0')
GOTO 300
ENDIF
L = 10
IF (VERS.GT.0) L = ((FIEL(VARF(I))+9)/10)*10
CALL GST(VVAL,J+1,VVAL(J),L,Z"20",0)
J = J + 1 + VVAL(J)
CALL COMMENT('*')
GOTO 110
C
C RANGE
C
200 CONTINUE
CALL LABELN('VAL',I)
CALL VFDO('60/',VVAL(VARV(I)))
CALL VFDO('60/',VVAL(VARV(I)+1))
300 CONTINUE
END
C-------------------------------------------------------------------
C* INCI - INCREMENT I POSITION (BUT NOT X)
C
SUBROUTINE INCI
SI = SI + 1
END
C-------------------------------------------------------------------
C* INCX - INCREMENT X POSITION
C
SUBROUTINE INCX
SX = SX + 1
SI = SI + 1
END
C-------------------------------------------------------------------
C* INCY - INCREMENT Y POSITION
C
SUBROUTINE INCY
SJ = SJ + 1
END
C-------------------------------------------------------------------
C* ISA - IS ALPHABETIC
C
C ENTRY
C C = CHARACTER TO TEST
C
LOGICAL FUNCTION ISA(C)
*CALL COMFPAN
INTEGER C
ISA = C.GE.ZAA.AND.C.LE.ZZZ.OR.
A C.GE.ZA.AND.C.LE.ZZ
END
C-------------------------------------------------------------------
C* ISAN - IS ALPHANUMERIC
C
C ENTRY C=CHARACTER TO TEST
C
LOGICAL FUNCTION ISAN(C)
*CALL COMFPAN
INTEGER C
ISAN = ISA(C).OR.ISN(C)
END
C-------------------------------------------------------------------
C* ISCOR - IS A CORNER
C
C ENTRY C = ASCII CHAR TO TEST
C
LOGICAL FUNCTION ISCOR(C)
*CALL COMFPAN
INTEGER C
ISCOR = (SPCH(C).LT.0.AND.SPCH(C).NE.-128).OR.C.EQ.128
END
C-------------------------------------------------------------------
C* ISLCH - IS A HORIZONTAL LINE OR A CORNER
C
C ENTRY C = ASCII CHAR TO TEST
C
LOGICAL FUNCTION ISLCH(C)
*CALL COMFPAN
INTEGER C
ISLCH = ISCOR(C).OR.ISLINH(C)
END
C-------------------------------------------------------------------
C* ISLCV - IS A VERTICAL LINE OR A CORNER
C
C ENTRY C = ASCII CHAR TO TEST
C
LOGICAL FUNCTION ISLCV(C)
*CALL COMFPAN
INTEGER C
ISLCV = ISCOR(C).OR.ISLINV(C)
END
C-------------------------------------------------------------------
C* ISLINH - IS A HORIZONTAL LINE (OF A BOX)
C
C ENTRY C = ASCII CHAR TO TEST
C
LOGICAL FUNCTION ISLINH(C)
*CALL COMFPAN
INTEGER C
ISLINH = C.EQ.ZMI
END
C-------------------------------------------------------------------
C* ISLINV - IS A VERTICAL LINE (OF A BOX)
C
C ENTRY C = ASCII CHAR TO TEST
C
LOGICAL FUNCTION ISLINV(C)
*CALL COMFPAN
INTEGER C
ISLINV = C.EQ.ZVB
END
C-------------------------------------------------------------------
C* ISN - IS NUMERIC
C
C ENTRY
C C = CHARACTER TO TEST
C
LOGICAL FUNCTION ISN(C)
*CALL COMFPAN
INTEGER C
ISN = C.GE.Z0.AND.C.LE.Z9
END
C-------------------------------------------------------------------
C* ITODC - INTEGER TO DISPLAY CODE FUNCTION
C
C ENTRY
C INT = INTEGER TO CONVERT
C DC = CHARACTER*10 TO RECEIVE RESULT
C EXIT
C I = INDEX TO START OF RESULT IN DC
C DC(I:) = RESULT
C
SUBROUTINE ITODC(INT,DC,I)
*CALL COMFPAN
INTEGER INT, I
CHARACTER*10 DC
INTEGER N
N = IABS(INT)
I = 10
1 DC(I:I) = CHAR(N - ((N/10)*10) + ICHAR('0'))
N = N/10
IF (N.EQ.0) THEN
IF (INT.LT.0.AND.I.GT.1) THEN
I = I - 1
DC(I:I) = '-'
RETURN
ELSEIF (INT.GE.0) THEN
RETURN
ENDIF
ENDIF
I = I - 1
IF (I.GT.0) GOTO 1
DC = '**********'
END
C-------------------------------------------------------------------
C LABEL - GENERATE A LABEL
C
SUBROUTINE LABEL(S)
*CALL COMFPAN
CHARACTER*(*) S
WRITE(3,100) S
100 FORMAT(A, T10, 'BSS', T16, '0')
END
C-------------------------------------------------------------------
C* LABELN - GENERATE A LABEL SUFFIXED BY INTEGER N
C
C ENTRY S=LABEL NAME
C N=LABEL INTEGER
C
SUBROUTINE LABELN(S,N)
*CALL COMFPAN
CHARACTER*(*) S
INTEGER N
WRITE(3,100) S, N
100 FORMAT(A, I4.4, T10, 'BSS', T16, '0')
END
C-------------------------------------------------------------------
C* NEEDHED - ERROR IF NOT VAR, KEY, ATTR OR BRACKET
C SKIP FORWARD TO ONE
C
SUBROUTINE NEEDHED(I)
*CALL COMFPAN
INTEGER I
IF (FATAL) CALL SKIPHED
CALL CHEKHED(I)
IF(I.EQ.0) THEN
CALL EXPECT('VAR, KEY, ATTR, BOX, TABLE ^O^R ^2',' ')
CALL SKIPHED
ENDIF
END
C-------------------------------------------------------------------
C* NEWATR - NEW ATTRIBUTE
C
SUBROUTINE NEWATR
*CALL COMFPAN
IF (NATR.GE.MATR) THEN
CALL ERRORN(MATR,'^A^T^T^R^I^B^U^T^E^S')
RETURN
ENDIF
NATR = NATR + 1
ATCS(NATR) = 0
ATCE(NATR) = 0
ATSC(NATR) = 0
ATRLP(NATR) = '1'
ATRUL(NATR) = '0'
ATRAI(NATR) = '0'
ATRIV(NATR) = '0'
ATRBL(NATR) = '0'
ATTP(NATR) = 0
ATBI(NATR) = 0
ATLW(NATR) = 0
ATIO(NATR) = 2
END
C-------------------------------------------------------------------
C* NEWCON - NEW CONSTANT
C
C ENTRY
C X = X POSITION ON SCREEN
C Y = Y POSITION ON SCREEN
C I = COLUMN IN IMAG ARRAY
C L = NUMBER OF CHARACTERS
C A = ATTRIBUTE ORDINAL
C
SUBROUTINE NEWCON(X,Y,I,L,A)
*CALL COMFPAN
INTEGER X,Y,I,L,A
IF (NFIE.GE.(MFIE)) THEN
CALL ERRORN(MFIE,'TOTAL C^O^N^S^T^A^N^T ^A^N^D V^A^R^I^A^B^L^E
+ ^F^I^E^L^D^S')
RETURN
ENDIF
IF (NCON.GT.MCON) THEN
CALL ERRORN(NCON,'C^O^N^S^T^A^N^T ^F^I^E^L^D^S')
RETURN
ENDIF
NCON = NCON + 1
NFIE = NFIE + 1
FIEX(NFIE) = X
FIEY(NFIE) = Y
FIEL(NFIE) = L
FIET(NFIE) = 0
FIEV(NFIE) = NCON
FIEO(NFIE) = 0
FIEA(NFIE) = A
CONI(NCON) = I
CONF(NCON) = NFIE
END
C-------------------------------------------------------------------
C* NEWHL - NEW HORIZONTAL LINE
C
C ENTRY
C I,J=START OF LINE
C L = LENGTH
C
SUBROUTINE NEWHL(I,J,L)
*CALL COMFPAN
INTEGER I,J,L
CALL NEWLC(I,J,L,0)
DO 100 K = 1, L
IMAG(I+K-1,J) = ZSP
100 CONTINUE
NCOL = MAX(NCOL,I+L-1)
END
C-------------------------------------------------------------------
C* NEWLC - NEW LINE OR CORNER
C
C ENTRY
C I,J= POS ON SCREEN
C L = LEN FOR LINE
C T = TYPE (BOXHL, BOXVL, OR CORNER TYPE)
C
SUBROUTINE NEWLC(I,J,L,T)
*CALL COMFPAN
INTEGER I,J,L,T
IF (IBOX.GT.255) THEN
CALL ERRORN(256,'^B^O^X^ ^E^L^E^M^E^N^T^S')
RETURN
ENDIF
IBOX = IBOX + 1
BOXN(IBOX) = L
BOXX(IBOX) = I - 1
BOXY(IBOX) = J - 1
BOXC(IBOX) = T
BOXA(IBOX) = NBOX
END
C-------------------------------------------------------------------
C* NEWVAR - INITIALIZE VARIABLE
C
SUBROUTINE NEWVAR
*CALL COMFPAN
IF (NVAR.EQ.MVAR) THEN
CALL ERRORN(MVAR,'^V^A^R^I^A^B^L^E^S')
RETURN
ENDIF
NVAR = NVAR + 1
VTAB(NVAR) = 0
VAIO(NVAR) = 0
VARL(NVAR) = 0
VARV(NVAR) = 0
VART(NVAR) = VTC
VARM(NVAR) = VMK
VARC(NVAR) = 0
VARP(NVAR) = 0
VAVT(NVAR) = 0
VARH(NVAR) = 0
VARD(NVAR) = 0
VARA(NVAR) = 1
VARF(NVAR) = 0
VARR(NVAR) = 0
VARNM(NVAR) = '*'
END
C-------------------------------------------------------------------
C* NEWVAT - NEW VARIABLE ATTRIBUTE
C
SUBROUTINE NEWVAT
*CALL COMFPAN
IF (VARA(NVAR).EQ.1) THEN
CALL NEWATR
IF (FATAL) RETURN
ATIO(NATR) = 0
VARA(NVAR) = NATR - 1
ENDIF
END
C-------------------------------------------------------------------
C* NEWVL - NEW VERTICAL LINE
C
C ENTRY
C I,J= POS OF START OF LINE
C L=LENGTH
C
SUBROUTINE NEWVL(I,J,L)
*CALL COMFPAN
INTEGER I,J,L
CALL NEWLC(I,J,L,1)
DO 100 K = 1, L
IMAG(I,J+K-1) = ZSP
100 CONTINUE
END
C-------------------------------------------------------------------
C* PACKATR - PACK ATTRIBUTES DOWN
C
C CHECK THE ATTRIBUTE LIST TO SEE IF NATR IS UNIQUE.
C IF NOT, POP NATR AND RETURN THE ORDINAL OF THE
C IDENTICAL ATTRIBUTE. IF SO, RETURN NATR.
C
INTEGER FUNCTION PACKATR()
*CALL COMFPAN
INTEGER I
DO 100 I = 1, NATR-1
IF (ATRLP(NATR).EQ.ATRLP(I).AND.
A ATRUL(NATR).EQ.ATRUL(I).AND.
B ATRAI(NATR).EQ.ATRAI(I).AND.
C ATRIV(NATR).EQ.ATRIV(I).AND.
D ATRBL(NATR).EQ.ATRBL(I).AND.
E ATIO(NATR).EQ.ATIO(I).AND.
F ATTP(NATR).EQ.ATTP(I).AND.
H ATCS(NATR).EQ.ATCS(I).AND.
I ATCE(NATR).EQ.ATCE(I).AND.
J ATSC(NATR).EQ.ATSC(I).AND.
K ATBI(NATR).EQ.ATBI(I).AND.
L ATLW(NATR).EQ.ATLW(I)) GOTO 200
100 CONTINUE
PACKATR = NATR
RETURN
200 PACKATR = I
NATR = NATR - 1
END
C-------------------------------------------------------------------
C* QUIT - ABNORMALLY TERMINATE THE JOB
C
C ENTRY M=MESSAGE TO DISPLAY
C
SUBROUTINE QUIT(M)
*CALL COMFPAN
CHARACTER*(*) M
CHARACTER*80 MESSAGE
MESSAGE = ' ERROR IN ' // PNAME(1:CLEN(PNAME)) //
A ' ' // M // ':::'
CALL QUITS(MESSAGE)
END
C-------------------------------------------------------------------
C* QUITS - ABNORMALLY TERMINATE THE JOB FOR SYSTEM REASONS
C
C ENTRY M=MESSAGE TO DISPLAY
C
SUBROUTINE QUITS(M)
*CALL COMFPAN
CHARACTER*(*) M
CHARACTER*80 MESSAGE
MESSAGE = ' PANEL - ' // M // ':::'
REWIND 1
REWIND 2
REWIND 3
CALL MSG(MESSAGE)
CALL ABT
END
C-------------------------------------------------------------------
C* READL1 - READ A LINE INTO LINE
C
SUBROUTINE READL1
*CALL COMFPAN
READ(1,100,END=999) LINE
100 FORMAT(A)
WRITE(2,150) LINE
150 FORMAT(' ',A)
CALL XLINE(1)
SJ = 1
RETURN
999 CONTINUE
IF (INDEF) THEN
CALL ERROR('U^N^E^X^P^E^C^T^E^D ^E^N^D ^O^F ^F^I^L^E')
CALL QUIT ('END OF FILE DURING DEFINITIONS')
ELSE
CALL QUIT ('NO DEFINITION OR IMAGE')
ENDIF
ENDFILE = .TRUE.
END
C-------------------------------------------------------------------
C* RPI - READ PANEL IMAGE
C
SUBROUTINE RPI
*CALL COMFPAN
DO 200 I = 2,MROW+1
READ(1,100,END=300) LINE
100 FORMAT(A)
WRITE(2,150) LINE
150 FORMAT(' ',A)
IF (I.LE.MROW) THEN
CALL XLINE(I)
ENDIF
200 CONTINUE
CALL ERROR('PANEL IMAGE EXCEEDS 64 LINES')
NROW = MROW
RETURN
300 CONTINUE
NROW = I - 1
END
C-------------------------------------------------------------------
C* SCANATR - SCAN ATTRIBUTE
C
SUBROUTINE SCANATR
*CALL COMFPAN
LOGICAL HAVDEL
HAVDEL = .FALSE.
N = 0
1 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
2 CONTINUE
IF (ZEQNEXT()) THEN
IF (UPSYMEQ('DELIMITERS').OR.UPSYMEQ('D')) THEN
I = 1
ELSEIF (UPSYMEQ('PHYSICAL').OR.UPSYMEQ('P')) THEN
I = 2
ELSEIF (UPSYMEQ('LOGICAL').OR.UPSYMEQ('L')) THEN
I = 3
ELSE
CALL EXPECT('DELIMITERS, LOGICAL, ^O^R PHYSICAL',
A 'ATTR')
RETURN
ENDIF
CALL SKIPTWO
IF (FATAL) RETURN
GOTO (100,200,300), I
ELSE
CALL CHEKHED(J)
IF (J.NE.0) THEN
IF (.NOT.HAVDEL) THEN
CALL EXPECT('DELIMITERS','ATTR')
RETURN
ENDIF
RETURN
ENDIF
N = N + 1
GOTO (100,200,300), N
CALL ERROR('T^O^O ^M^A^N^Y ATTR ^P^A^R^A^M^E^T^E^R^S')
RETURN
ENDIF
C
C DELIMITERS
C
100 CONTINUE
HAVDEL = .TRUE.
CALL NEWATR
IF (FATAL) RETURN
IF (SYMTP.EQ.'S') THEN
IF (SL.EQ.1) THEN
ATCS(NATR) = STRG(1)
ATCE(NATR) = STRG(1)
ELSEIF (SL.EQ.2) THEN
ATCS(NATR) = STRG(1)
ATCE(NATR) = STRG(2)
ELSE
CALL ERROR('S^T^R^I^N^G ^L^E^N^G^T^H')
RETURN
ENDIF
SPCH(ATCS(NATR)) = NATR
ELSE
CALL EXPECT('Q^U^O^T^E^D ^D^E^L^I^M^I^T^E^R^S',' ')
RETURN
ENDIF
SPCH(ATCS(NATR)) = NATR
GOTO 1
C
C PHYSICAL
C
200 CONTINUE
CALL SCANLPA(0)
IF (FATAL) RETURN
GOTO 1
C
C LOGICAL
C
300 CONTINUE
CALL SCANLPA(1)
IF (FATAL) RETURN
GOTO 1
END
C-------------------------------------------------------------------
C* SCANBOX - SCAN BOX
C
SUBROUTINE SCANBOX
*CALL COMFPAN
INTEGER I, N
LOGICAL HAVCH
HAVCH = .FALSE.
IF (NBOX.GE.MBOX) THEN
CALL ERRORN(MBOX,'^B^O^X^E^S')
RETURN
ENDIF
CALL NEWATR
IF (FATAL) RETURN
NBOX = NBOX + 1
BOXW(NBOX) = NATR
ATLW(NATR) = 1
ATTP(NATR) = 1
N = 0
1 CONTINUE
CALL SCANSYM
IF (ZEQNEXT()) THEN
IF (UPSYMEQ('TERMINATOR').OR.UPSYMEQ('T')) THEN
I = 1
ELSEIF (UPSYMEQ('WEIGHT').OR.UPSYMEQ('W')) THEN
I = 2
ELSEIF (UPSYMEQ('PHYSICAL').OR.UPSYMEQ('P')) THEN
I = 3
ELSEIF (UPSYMEQ('LOGICAL').OR.UPSYMEQ('L')) THEN
I = 4
ELSE
CALL EXPECT('TERMINATOR= ^O^R WEIGHT=','BOX')
RETURN
ENDIF
CALL SKIPTWO
IF (FATAL) RETURN
N = 4
GOTO (100,200,300,400), I
ELSE
CALL CHEKHED(I)
IF (I.NE.0) THEN
IF (.NOT.HAVCH) THEN
CALL ERROR('TERMINATOR ^C^H^A^R ^R^E^Q^U^I^R^E^D')
ENDIF
RETURN
ENDIF
N = N + 1
GOTO (100,200,300,400), N
CALL EXPECT('E^N^D ^O^F BOX ^D^E^C^L^A^R^A^T^I^O^N',' ')
RETURN
ENDIF
C
C TERMINATOR
C
100 CONTINUE
HAVCH = .TRUE.
IF (FATAL) RETURN
IF (SYMTP.NE.'S'.OR.SL.NE.1) THEN
CALL EXPECT('TERMINATOR ^C^H^A^R^A^C^T^E^R',' ')
RETURN
ENDIF
IF (SPCH(IMAG(SI,1)).NE.0) THEN
CALL ERROR('D^O^U^B^L^Y ^D^E^F^I^N^E^D')
RETURN
ENDIF
SPCH(STRG(1)) = -NBOX
GOTO 1
C
C WEIGHT
C
200 CONTINUE
IF (UPSYMEQ('FINE').OR.UPSYMEQ('F')) THEN
ATLW(NATR) = 1
ELSEIF (UPSYMEQ('MEDIUM').OR.UPSYMEQ('M')) THEN
ATLW(NATR) = 2
ELSEIF (UPSYMEQ('BOLD').OR.UPSYMEQ('B')) THEN
ATLW(NATR) = 3
ELSE
CALL EXPECT('FINE, MEDIUM, ^O^R BOLD','WEIGHT=')
RETURN
ENDIF
GOTO 1
C
C PHYSICAL
C
300 CONTINUE
CALL SCANLPA(0)
IF (FATAL) RETURN
GOTO 1
C
C LOGICAL
C
400 CONTINUE
CALL SCANLPA(1)
IF (FATAL) RETURN
GOTO 1
END
C-------------------------------------------------------------------
C* SCANCAS - SCAN CASE LIST
C
C CASE CONSTANTS ARE COPIED TO THE VVAL ARRAY. EACH CONSTANT
C IS PRECEDED BY ITS LENGTH. THE LIST IS TERMINATED BY A LENGTH
C OF -1.
C
SUBROUTINE SCANCAS
*CALL COMFPAN
SAVV = NVAL + 1
IF (.NOT.SYMEQ('(')) THEN
CALL EXPECT('^L^I^S^T','MATCH')
RETURN
ENDIF
N = 0
1 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
IF (SYMEQ(')')) THEN
IF (N.EQ.0) THEN
CALL ERROR('E^M^P^T^Y MATCH ^L^I^S^T')
RETURN
ENDIF
IF (NVAL.GE.MVAL) THEN
CALL ERR('VALIDATION TABLE OVERFLOW')
RETURN
ENDIF
NVAL = NVAL + 1
VVAL(NVAL) = -1
VARV(NVAR) = SAVV
VAVT(NVAR) = VTMATCH
RETURN
ENDIF
N = N + 1
CALL COPYSYM
IF (FATAL) RETURN
GOTO 1
END
C-------------------------------------------------------------------
C* SCANDEF - SCAN PANEL DEFINITION
C
SUBROUTINE SCANDEF
*CALL COMFPAN
INTEGER I, J, N
LOGICAL INTABL
INTABL = .FALSE.
2 CALL SCANSYM
1 CONTINUE
IF (SYMEQ(';')) GOTO 2
ABEND = ABEND.OR.FATAL
IF (.NOT.INDEF) RETURN
CALL NEEDHED(I)
ABEND = ABEND.OR.FATAL
IF (ENDFILE) RETURN
FATAL = .FALSE.
GOTO (100,200,300,400,500,600,700,800,900),I
RETURN
C
C VAR
C
100 CONTINUE
* INITIALIZE DEFAULT LOGICAL ATTRIBUTES FLAG.
DEFLOGA = .TRUE.
CALL SCANVAR
* TYPE IO=OUT WITH DEFAULT LOGICAL ATTRIBUTES IS SET TO LOGICAL=TEXT.
IF ((DEFLOGA) .AND.(VAIO(NVAR) .EQ. 2)) THEN
ATTP(NATR) = 1
ENDIF
IF (FATAL) GOTO 1
IF (INTABL) THEN
VTAB(NVAR) = NTAB
ENDIF
IF (VARA(NVAR).EQ.NATR-1) THEN
VARA(NVAR) = PACKATR() - 1
ENDIF
GOTO 1
C
C KEY
C
200 CALL SCANKEY
GOTO 1
C
C ATTR
C
300 CALL SCANATR
GOTO 1
C
C RIGHT CURLY BRACKET
C
400 CALL READL1
RETURN
C
C BOX
C
500 CALL SCANBOX
IF (FATAL) GOTO 2
GOTO 1
C
C TABLE
C
600 CONTINUE
IF (INTABL) THEN
CALL ERROR('A^L^R^E^A^D^Y ^I^N ^T^A^B^L^E')
CALL SCANSYM
GOTO 1
ENDIF
INTABL = .TRUE.
IF (NTAB.GE.MTAB) THEN
CALL ERRORN(MTAB,'^T^A^B^L^E^S')
RETURN
ENDIF
NTAB = NTAB + 1
TABNM(NTAB) = '*'
TABD(NTAB) = 1
TABF(NTAB) = NVAR + 1
CALL SCANTAB
IF (FATAL) RETURN
GOTO 1
C
C ENDTABLE
C
700 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
IF (.NOT.INTABL) THEN
CALL ERROR('N^O^T ^I^N ^T^A^B^L^E')
GOTO 1
ENDIF
INTABL = .FALSE.
IF (TABF(NTAB).GT.NVAR) THEN
CALL ERROR('E^M^P^T^Y ^T^A^B^L^E')
NTAB = NTAB - 1
GOTO 1
ENDIF
TABR(NTAB) = NVAR + 1 - TABF(NTAB)
N = NVAR
DO 750 I = 1, TABD(NTAB)-1
DO 750 J = TABF(NTAB), N
CALL COPYVAR(J,I)
750 CONTINUE
TABL(NTAB) = NVAR
GOTO 1
C
C PANEL
C
800 CONTINUE
CALL SCANPAN
GOTO 1
C
C SFATTR
C
900 CONTINUE
IF (NATR.GT.3) THEN
CALL ERROR('SFATTR AFTER OTHER ATTRIBUTES')
ABEND = .TRUE.
RETURN
ENDIF
CALL SCANSYM
IF (FATAL) RETURN
DO 950 J = 0,2
DO 950 I = 0,11
NATR = NATR + 1
ATRLP(NATR) = '1'
ATIO(NATR) = J
ATTP(NATR) = I
950 CONTINUE
GOTO 1
END
C-------------------------------------------------------------------
C* SCANIMG - SCAN PANEL IMAGE
C
SUBROUTINE SCANIMG
*CALL COMFPAN
CHARACTER*7 VNAME
INTEGER HIHV
C
C PREPARE IMAGE
C
DO 1 J = 1, MROW
IMAG(MCOL+1,J) = 1
1 CONTINUE
C
C START COUNTING VAR DATA AND VARS FOUND
C
VDCO = 0
NVAF = 0
HIHV = NVAR
LFIE = 0
NFIE = 0
SPCH(128) = -128
SPCH(ZUL) = -128
C
C SCAN
C
DO 1000 J = 1, NROW
I = 1
C
C SKIP BLANKS
C
100 IF (I.LE.MCOL) THEN
IF (IMAG(I,J).EQ.ZSP) THEN
I = I + 1
GOTO 100
ENDIF
C
C VARIABLE
C
K = SPCH(IMAG(I,J))
IF (IMAG(I,J).EQ.ZUL) THEN
IF ((J.EQ.1) .AND.
A (VAIO(NFIE+1) .NE. 2)) THEN
CALL ERROR('I^N^P^U^T ^F^I^E^L^D ^O^N' //
A ' ^F^I^R^S^T ^L^I^N^E ^O^F ^I^M^A^G^E')
RETURN
ENDIF
SI = I
TMPX = I - 1
200 I = I + 1
IF (IMAG(I,J).EQ.ZUL) GOTO 200
NCOL = MAX(NCOL,I-1)
NFIE = NFIE + 1
NVAF = NVAF + 1
IF (NVAF.LE.NVAR) THEN
IF (I-SI.NE.VARL(NVAF).AND.VARL(NVAF).NE.0) THEN
CALL ERROR('FIELD DECLARED DIFFERENT SIZE')
ENDIF
ELSE
CALL NEWVAR
IF (FATAL) RETURN
ENDIF
FIEX(NFIE) = TMPX
FIEY(NFIE) = J - 1
FIEL(NFIE) = I - SI
FIET(NFIE) = 1
FIEV(NFIE) = NVAF
FIEO(NFIE) = VDCO
FIEA(NFIE) = VARA(NVAF)
VARF(NVAF) = NFIE
VDCO = VDCO + FIEL(NFIE)
GOTO 100
C
C ATTRIBUTE
C
ELSEIF (K.GT.0) THEN
SI = I + 1
300 I = I + 1
IF (I.LE.MCOL.AND.IMAG(I,J).NE.ATCE(K)) GOTO 300
NCOL = MAX(NCOL,I-1)
IF (I-SI.GT.0) THEN
CALL NEWCON(SI-1, J-1, SI, I-SI, K-1)
IF (FATAL) RETURN
ENDIF
I = I + 1
GOTO 100
C
C BOX
C
ELSEIF (K.LT.0) THEN
CALL DOBOX(I,J,-K)
I = I + 1
GOTO 100
C
C PLAIN OLD CONSTANT
C
ELSE
SI = I
400 I = I + 1
IF (I.LE.MCOL.AND.
A IMAG(I,J).NE.ZSP.AND.
B SPCH(IMAG(I,J)).EQ.0) GOTO 400
IF (I.LT.MCOL.AND.
A IMAG(I,J).EQ.ZSP.AND.
B IMAG(I+1,J).NE.ZSP) GOTO 400
NCOL = MAX(NCOL,I-1)
CALL NEWCON(SI-1, J-1, SI, I-SI, 2)
IF (FATAL) RETURN
GOTO 100
ENDIF
ENDIF
1000 CONTINUE
IF (HIHV.NE.NVAR.OR.NVAF.NE.NVAR) THEN
CALL ERROR('D^I^F^F^E^R^E^N^T ^N^U^M^B^E^R ^O^F' //
A ' ^F^I^E^L^D^S ^T^H^A^N ^D^E^C^L^A^R^E^D')
ENDIF
END
C-------------------------------------------------------------------
C* SCANINT - SCAN INTEGER
C
SUBROUTINE SCANINT
*CALL COMFPAN
1 IF (ISN(IMAG(SJ,1))) THEN
SJ = SJ + 1
GOTO 1
ENDIF
END
C-------------------------------------------------------------------
C SCANKEY - SCAN KEY DECLARATION
C
SUBROUTINE SCANKEY
*CALL COMFPAN
N = 0
CALL SCANSYM
1 CONTINUE
IF (FATAL) RETURN
IF (ZEQNEXT()) THEN
IF (UPSYMEQ('NORMAL').OR.UPSYMEQ('N')) THEN
I = 1
ELSEIF (UPSYMEQ('ABNORMAL').OR.UPSYMEQ('A')) THEN
I = 2
ELSEIF (UPSYMEQ('HELP').OR.UPSYMEQ('H')) THEN
I = 3
ELSEIF (UPSYMEQ('MATCH').OR.UPSYMEQ('M')) THEN
I = 4
ELSE
CALL EXPECT('NORMAL=, ABNORMAL=, HELP= ^O^R MATCH=','KEY')
RETURN
ENDIF
CALL SKIPTWO
IF (FATAL) RETURN
N = 4
GOTO (100,200,300,400), I
ELSE
N = N + 1
GOTO (100,200,300,400), N
CALL CHEKHED(I)
IF (I.EQ.0) THEN
CALL EXPECT('NORMAL=, ABNORMAL=, HELP= ^O^R '//
A 'MATCH=(^K^E^Y^S)','KEY')
ENDIF
RETURN
ENDIF
C
C NORMAL
C
100 CONTINUE
CALL SCANKYS(1)
IF (FATAL) RETURN
GOTO 1
C
C ABNORMAL
C
200 CONTINUE
CALL SCANKYS(3)
IF (FATAL) RETURN
GOTO 1
C
C HELP
C
300 CONTINUE
CALL SCANKYS(9)
IF (FATAL) RETURN
GOTO 1
C
C MATCH
C
400 CONTINUE
CALL SCANKYS(10)
IF (FATAL) RETURN
GOTO 1
END
C-------------------------------------------------------------------
C* SCANKYS - SCAN KEY LIST
C
C ENTRY K=ACTION
C
SUBROUTINE SCANKYS(K)
*CALL COMFPAN
LOGICAL LOOP
IF (SYMEQ('(')) THEN
LOOP = .TRUE.
GOTO 1
ELSE
LOOP = .FALSE.
GOTO 2
ENDIF
1 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
2 CONTINUE
CALL CHEKKEY(I,J)
IF (FATAL) RETURN
IF (I.EQ.0) THEN
IF (LOOP) THEN
IF (SYMEQ(')')) THEN
CALL SCANSYM
ELSE
CALL EXPECT(')','KEY ^L^I^S^T')
ENDIF
ENDIF
RETURN
ENDIF
IF (NFUN.GE.MFUN) THEN
CALL ERRORN(MKEY,'^K^E^Y^S')
RETURN
ENDIF
NFUN = NFUN + 1
FUNG(NFUN) = I/2
FUNK(NFUN) = J
FUNA(NFUN) = K
IF (LOOP) GOTO 1
CALL SCANSYM
END
C-------------------------------------------------------------------
C SCANLEN - SCAN VAR LENGTH
C
SUBROUTINE SCANLEN
*CALL COMFPAN
IF (SYMEQ('(')) THEN
CALL SCANSYM
IF (FATAL) RETURN
IF (SYMTP.EQ.'N') THEN
VARL(NVAR) = SINT
CALL SCANSYM
IF (FATAL) RETURN
IF (SYMEQ(')')) THEN
CALL SCANSYM
RETURN
ELSE
CALL EXPECT(')','VAR ^L^E^N^G^T^H')
ENDIF
ELSE
CALL EXPECT('VAR ^L^E^N^G^T^H','(')
ENDIF
ENDIF
VARL(NVAR) = 0
END
C-------------------------------------------------------------------
C* SCANLPA - SCAN LOGICAL/PHYSICAL ATTRIBUTE
C
C ENTRY LOG=1 IF LOGICAL ATTRIBUTES, 0 IF PHYSICAL
C
SUBROUTINE SCANLPA(LOG)
*CALL COMFPAN
INTEGER LOG
LOGICAL LOOP
CHARACTER*8 LOGIC(2)
DATA LOGIC /'PHYSICAL','LOGICAL'/
IF (SYMEQ('(')) THEN
LOOP = .TRUE.
GOTO 1
ELSE
LOOP = .FALSE.
GOTO 2
ENDIF
1 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
2 CONTINUE
CALL CHEKATR(LP,I)
IF (LP.EQ.3) THEN
IF (SYMEQ(')')) RETURN
CALL EXPECT(LOGIC(LOG+1)//' ^A^T^T^R^I^B^U^T^E',' ')
RETURN
ENDIF
IF (LP.NE.LOG) THEN
CALL ERROR('^A^T^T^R^I^B^U^T^E ^N^O^T '//LOGIC(LOG+1))
RETURN
ENDIF
CALL SETATR(LP,I)
IF (LOOP) GOTO 1
END
C-------------------------------------------------------------------
C* SCANMUS - SCAN ENTRY
C
SUBROUTINE SCANMUS
*CALL COMFPAN
LOGICAL LOOP
IF (SYMEQ('(')) THEN
LOOP = .TRUE.
GOTO 1
ELSE
LOOP = .FALSE.
GOTO 2
ENDIF
1 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
2 CONTINUE
IF (SYMEQ(')')) RETURN
IF (UPSYMEQ('MUST')) THEN
CALL SCANSYM
IF (FATAL) RETURN
ENDIF
IF (UPSYMEQ('FILL')) THEN
VARM(NVAR) = OR(VARM(NVAR),VMF)
ELSEIF (UPSYMEQ('ENTER').OR.UPSYMEQ('E')) THEN
VARM(NVAR) = OR(VARM(NVAR),VME)
ELSEIF (UPSYMEQ('UNKNOWN').OR.UPSYMEQ('U')) THEN
VARM(NVAR) = AND(VARM(NVAR),COMPL(VMK))
ELSEIF (UPSYMEQ('CONTAIN').OR.UPSYMEQ('C')) THEN
VARC(NVAR) = 1
ELSE
CALL EXPECT('MUST FILL, ENTER, CONTAIN ^O^R UNKNOWN','ENTRY')
RETURN
ENDIF
IF (LOOP) GOTO 1
END
C-------------------------------------------------------------------
C* SCANPAN - SCAN PANEL KEYWORDS
C
SUBROUTINE SCANPAN
*CALL COMFPAN
N = 0
1 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
IF (ZEQNEXT()) THEN
IF (UPSYMEQ('NAME').OR.UPSYMEQ('N')) THEN
I = 1
ELSE IF (UPSYMEQ('TYPE').OR.UPSYMEQ('T')) THEN
I = 2
ELSE
CALL EXPECT('TYPE=','PANEL')
RETURN
ENDIF
CALL SKIPTWO
IF (FATAL) RETURN
N = 2
GOTO (100,200), I
ELSE
CALL CHEKHED(I)
IF (I.NE.0) RETURN
N = N + 1
GOTO (100,200), N
CALL EXPECT('NAME ^O^R TYPE','PANEL')
RETURN
ENDIF
C
C NAME
C
100 CONTINUE
IF (SYMTP.NE.'I') THEN
CALL EXPECT('PANEL ^N^A^M^E','PANEL')
RETURN
ENDIF
PNAME = STRGD(1:SL)
GOTO 1
C
C TYPE
C
200 CONTINUE
IF (UPSYMEQ('PRIMARY')) THEN
ERBW = 1
ELSEIF (UPSYMEQ('OVERLAY')) THEN
ERBW = 0
ELSE
CALL EXPECT('PRIMARY ^O^R OVERLAY',' ')
RETURN
ENDIF
GOTO 1
END
C-------------------------------------------------------------------
C* SCANRNG - SCAN RANGE
C
SUBROUTINE SCANRNG
*CALL COMFPAN
IF (.NOT.SYMEQ('(')) THEN
CALL EXPECT('(','RANGE=')
RETURN
ENDIF
CALL SCANSYM
IF (FATAL) RETURN
IF (SYMTP.NE.'N'.AND.SYMTP.NE.'R') THEN
CALL EXPECT('^C^O^N^S^T^A^N^T','RANGE')
RETURN
ENDIF
C
C INTEGER RANGE
C
IF (NVAL.GE.MVAL-1) THEN
CALL ERR('VALIDATION TABLE OVERFLOW')
RETURN
ENDIF
IF (VART(NVAR).EQ.VTN) THEN
IF (SYMTP.NE.'N') THEN
CALL ERROR('C^O^N^S^T^A^N^T ^W^R^O^N^G ^T^Y^P^E')
RETURN
ENDIF
NVAL = NVAL + 1
VVAL(NVAL) = SINT
CALL SCANSYM
IF (FATAL) RETURN
IF (SYMTP.NE.'N') THEN
CALL EXPECT('^C^O^N^S^T^A^N^T^S','RANGE')
RETURN
ENDIF
IF (VVAL(NVAL).GT.SINT) THEN
CALL ERROR('RANGE ^L^O^W ^G^T ^H^I^G^H')
RETURN
ENDIF
NVAL = NVAL + 1
VVAL(NVAL) = SINT
VARV(NVAR) = NVAL - 1
VAVT(NVAR) = VTRANGE
CALL SCANSYM
GOTO 9999
C
C REAL RANGE
C
ELSEIF (VART(NVAR).EQ.VTR) THEN
IF (SYMTP.NE.'R') THEN
CALL ERROR('C^O^N^S^T^A^N^T ^W^R^O^N^G ^T^Y^P^E')
RETURN
ENDIF
NVAL = NVAL + 1
VREALV(NVAL) = SREALV
CALL SCANSYM
IF (FATAL) RETURN
IF (SYMTP.NE.'R') THEN
CALL EXPECT('^C^O^N^S^T^A^N^T^S','RANGE')
RETURN
ENDIF
IF (VREALV(NVAL).GT.SREALV) THEN
CALL ERROR('RANGE ^L^O^W ^G^T ^H^I^G^H')
RETURN
ENDIF
NVAL = NVAL + 1
VREALV(NVAL) = SREALV
VARV(NVAR) = NVAL - 1
VAVT(NVAR) = VTRANGE
CALL SCANSYM
GOTO 9999
C
C CHAR RANGE
C
ELSE
CALL ERROR('RANGE ^O^F CHAR ^N^O^T ^A^L^L^O^W^E^D')
RETURN
ENDIF
9999 CONTINUE
IF (FATAL) RETURN
IF (.NOT.SYMEQ(')')) THEN
CALL EXPECT(')','RANGE')
ENDIF
END
C-------------------------------------------------------------------
C* SCANSYM - SCAN SYMBOL FROM CURRENT POSITION
C
C ENTRY
C SJ = CURRENT POSITION
C EXIT
C SI = SYMBOL POSITION
C SJ = NEW CURRENT POSITION
C SYMTP = SYMBOL TYPE
C I = IDENTIFIER
C N = INTEGER
C P = PUNCTUATOR
C R = REAL
C S = STRING
C
SUBROUTINE SCANSYM
*CALL COMFPAN
CHARACTER*10 FMT
GOTO 2
1 CALL READL1
IF (FATAL) RETURN
2 CONTINUE
IF (SJ.GT.MCOL) GOTO 1
IF (IMAG(SJ,1).EQ.ZSP) THEN
SJ = SJ + 1
GOTO 2
ENDIF
IF (IMAG(SJ,1).EQ.ZQO) THEN
3 CONTINUE
SJ = SJ + 1
IF (SJ.GT.MCOL) GOTO 1
IF (IMAG(SJ,1).NE.ZQO) GOTO 3
SJ = SJ + 1
GOTO 2
ENDIF
C
SI = SJ
SL = 0
IF (ISA(IMAG(SJ,1))) THEN
GOTO 100
ELSEIF (ISN(IMAG(SJ,1))) THEN
GOTO 200
ELSEIF (IMAG(SJ,1).EQ.ZPL.OR.
A IMAG(SJ,1).EQ.ZMI) THEN
GOTO 200
ELSEIF (IMAG(SJ,1).EQ.ZPD) THEN
IF (IMAG(SJ+1,1).EQ.ZPD) THEN
SJ = SJ + 2
IF (IMAG(SJ,1).EQ.ZPD) SJ = SJ + 1
GOTO 2
ENDIF
GOTO 215
ELSEIF (IMAG(SJ,1).EQ.ZAP) THEN
SJ = SJ + 1
GOTO 300
ENDIF
SYMTP = 'P'
SL = 1
SJ = SJ + 1
GOTO 9999
C
C IDENTIFIER
C
100 IF (ISAN(IMAG(SJ,1))) THEN
SL = SL + 1
IF (IMAG(SJ,1).LT.ZAA) THEN
STRGD(SL:SL) = CHAR(IMAG(SJ,1) - Z0 + ICHAR('0'))
ELSE IF (IMAG(SJ,1).GT.ZZZ) THEN
STRGD(SL:SL) = CHAR(IMAG(SJ,1) - ZA + ICHAR('A'))
ELSE
STRGD(SL:SL) = CHAR(IMAG(SJ,1) - ZAA + ICHAR('A'))
ENDIF
SJ = SJ + 1
GOTO 100
ENDIF
SYMTP = 'I'
GOTO 9999
C
C NUMBER
C
C PLUS OR MINUS
200 CONTINUE
SIGN = 1
SINT = 0
SYMTP = 'N'
IF(IMAG(SJ,1).EQ.ZPL) THEN
SL = SL + 1
STRGD(SL:SL) = '+'
SJ = SJ + 1
ELSEIF (IMAG(SJ,1).EQ.ZMI) THEN
SL = SL + 1
STRGD(SL:SL) = '-'
SIGN = -1
SJ = SJ + 1
ENDIF
C DIGITS
210 IF (ISN(IMAG(SJ,1))) THEN
SL = SL + 1
STRGD(SL:SL) = CHAR(IMAG(SJ,1) - Z0 + ICHAR('0'))
SINT = SINT*10 + IMAG(SJ,1) - Z0
SJ = SJ + 1
GOTO 210
ENDIF
IF (IMAG(SJ,1).NE.ZPD.AND.IMAG(SJ,1).NE.ZE.AND.
A IMAG(SJ,1).NE.ZEE) THEN
SINT = SINT * SIGN
GOTO 9999
ENDIF
SYMTP = 'R'
C DECIMAL POINT
215 IF (IMAG(SJ,1).EQ.ZPD) THEN
SL = SL + 1
STRGD(SL:SL) = '.'
SJ = SJ + 1
ENDIF
C MORE DIGITS
220 IF (ISN(IMAG(SJ,1))) THEN
SL = SL + 1
STRGD(SL:SL) = CHAR(IMAG(SJ,1) - Z0 + ICHAR('0'))
SJ = SJ + 1
GOTO 220
ENDIF
C E
IF (IMAG(SJ,1).EQ.ZEE.OR.IMAG(SJ,1).EQ.ZE) THEN
SL = SL + 1
STRGD(SL:SL) = 'E'
SJ = SJ + 1
SYMTP = 'R'
ENDIF
C PLUS OR MINUS AGAIN
IF(IMAG(SJ,1).EQ.ZPL) THEN
SL = SL + 1
STRGD(SL:SL) = '+'
SJ = SJ + 1
ELSEIF (IMAG(SJ,1).EQ.ZMI) THEN
SL = SL + 1
STRGD(SL:SL) = '-'
SJ = SJ + 1
ENDIF
C STILL MORE DIGITS
230 IF (ISN(IMAG(SJ,1))) THEN
SL = SL + 1
STRGD(SL:SL) = CHAR(IMAG(SJ,1) - Z0 + ICHAR('0'))
SJ = SJ + 1
GOTO 230
ENDIF
C GET VALUE
IF (SYMTP.EQ.'N') THEN
SINT = SINT * SIGN
ELSE
WRITE(FMT,285) SL
285 FORMAT('(F',I2,'.0)')
C PRINT*,'REAL FORMAT=',FMT,' VALUE=',STRGD(1:SL)
READ(STRGD(1:SL),FMT,ERR=290) SREALV
C PRINT 57, SREALV
57 FORMAT(E20.10)
ENDIF
GOTO 9999
290 CALL ERROR('R^E^A^L ^C^O^N^S^T^A^N^T ^F^O^R^M^A^T')
SREALV = 0.0
GOTO 9999
C
C STRING
C
300 CONTINUE
IF (SJ.GT.MCOL) THEN
CALL ERROR('U^N^T^E^R^M^I^N^A^T^E^D ^S^T^R^I^N^G')
RETURN
ENDIF
IF (IMAG(SJ,1).EQ.ZAP) THEN
SJ = SJ + 1
IF (SJ.GT.MCOL) GOTO 300
IF (IMAG(SJ,1).EQ.ZAP) THEN
SL = SL + 1
STRG(SL) = IMAG(SJ,1)
SJ = SJ + 1
GOTO 300
ENDIF
ELSE
SL = SL + 1
STRG(SL) = IMAG(SJ,1)
SJ = SJ + 1
GOTO 300
ENDIF
SYMTP = 'S'
9999 CONTINUE
IF (SYMTP.EQ.'P') THEN
C PRINT 55, SYMTP, IMAG(SI,1)
55 FORMAT('SCANSYM ',A,' ', O3)
ELSE
C PRINT 56, SYMTP, SL, STRGD(1:SL)
56 FORMAT('SCANSYM ',A,' ',I3,' ',A)
ENDIF
END
C-------------------------------------------------------------------
C* SCANTAB - SCAN TABLE DEFINITION
C
SUBROUTINE SCANTAB
*CALL COMFPAN
LOGICAL HAVNAME, HAVDIM
HAVNAME = .FALSE.
HAVDIM = .FALSE.
N = 0
1 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
IF (ZEQNEXT()) THEN
IF (UPSYMEQ('NAME').OR.UPSYMEQ('N')) THEN
I = 1
ELSE IF (UPSYMEQ('ROWS').OR.UPSYMEQ('R')) THEN
I = 2
ELSE
CALL EXPECT('NAME= ^O^R ROWS=','TABLE')
RETURN
ENDIF
CALL SKIPTWO
IF (FATAL) RETURN
N = 2
GOTO (100,200), I
ELSE
N = N + 1
GOTO (100,200), N
IF (.NOT.HAVNAME) THEN
CALL ERROR('TABLE ^N^A^M^E ^R^E^Q^U^I^R^E^D')
RETURN
ENDIF
IF (.NOT.HAVDIM) THEN
CALL ERROR('TABLE ^D^I^M^E^N^S^I^O^N '//
A '^R^E^Q^U^I^R^E^D')
RETURN
ENDIF
CALL CHEKHED(I)
IF (I.EQ.0) THEN
CALL ERROR('TABLE ^P^A^R^A^M^E^T^E^R')
ENDIF
RETURN
ENDIF
C
C NAME
C
100 CONTINUE
IF (SYMTP.NE.'I') THEN
CALL EXPECT('TABLE ^N^A^M^E',' ')
RETURN
ENDIF
HAVNAME = .TRUE.
TABNM(NTAB) = STRGD(1:MIN(7,SL))
GOTO 1
C
C ROWS
C
200 CONTINUE
IF (.NOT.SYMTP.EQ.'N') THEN
CALL EXPECT('T^A^B^L^E ^D^I^M^E^N^S^I^O^N',' ')
RETURN
ENDIF
TABD(NTAB) = SINT
HAVDIM = .TRUE.
GOTO 1
END
C-------------------------------------------------------------------
C* SCANVAR - GET VARIABLE DEFINITION
C
SUBROUTINE SCANVAR
*CALL COMFPAN
LOGICAL HAVENAM
LOGICAL LOOP
HAVENAM = .FALSE.
NPARM = 0
1 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
2 CONTINUE
CALL SCANVKS(I)
IF (FATAL) RETURN
IF (I.EQ.0) THEN
CALL CHEKHED(J)
IF (FATAL) RETURN
IF (J.NE.0) THEN
IF (.NOT.HAVENAM) THEN
CALL ERROR('VAR ^N^A^M^E ^N^O^T ^S^P^E^C^I^F^I^E^D')
RETURN
ENDIF
IF ((VART(NVAR).EQ.VTN.OR.VART(NVAR).EQ.VTR).AND.
A (VARP(NVAR).LT.VP9)) THEN
CALL ERROR('TYPE/FORMAT ^M^I^S^M^A^T^C^H ^I^N '//
A '^P^R^E^C^E^D^I^N^G VAR')
RETURN
ENDIF
IF (VARP(NVAR).EQ.0) VARP(NVAR) = VPX
RETURN
ENDIF
NPARM = NPARM + 1
GOTO (100,200,300,400,500,600,
A 700,800,900,1000,1100), NPARM
CALL ERROR('T^O^O ^M^A^N^Y VAR ^P^A^R^A^M^E^T^E^R^S')
RETURN
ELSE
NPARM = 11
GOTO (100,200,300,400,500,600,
A 700,800,900,1000,1100), I
CALL ERR('INTERNAL ERROR: VAR KEYWORD')
RETURN
ENDIF
C
C NAME
C
100 CONTINUE
IF (HAVENAM) THEN
CALL ERROR('T^W^O VAR ^N^A^M^E^S')
RETURN
ENDIF
IF (SYMTP.NE.'I') THEN
CALL EXPECT('^V^A^R ^N^A^M^E','VAR')
RETURN
ELSE
CALL SETVARN
IF (FATAL) RETURN
ENDIF
HAVENAM = .TRUE.
GOTO 1
C
C TYPE
C
200 CONTINUE
IF (UPSYMEQ('CHAR')) THEN
VART(NVAR) = VTC
IF (VARP(NVAR).EQ.0) VARP(NVAR) = VPX
ELSEIF (UPSYMEQ('INT')) THEN
VART(NVAR) = VTN
IF (VARP(NVAR).EQ.0) VARP(NVAR) = VPN
ELSEIF (UPSYMEQ('REAL')) THEN
VART(NVAR) = VTR
IF (VARP(NVAR).EQ.0) VARP(NVAR) = VPE
ELSE
CALL EXPECT('CHAR, INT, ^O^R REAL','TYPE')
RETURN
ENDIF
GOTO 1
C
C VALUE
C
300 CONTINUE
CALL SETVARD
IF (FATAL) RETURN
GOTO 1
C
C FORMAT
C
400 CONTINUE
CALL CHEKPIC(I)
IF (I.EQ.0) THEN
CALL EXPECT('X, A, 9, N, E, $, YMD, MDY, ^O^R DMY','FORMAT')
RETURN
ENDIF
VARP(NVAR) = I
GOTO 1
C
C MATCH
C
500 CONTINUE
CALL SCANCAS
IF (FATAL) RETURN
GOTO 1
C
C LOGICAL
C
800 CONTINUE
* RESET DEFAULT LOGICAL ATTRIBUTES FLAG.
DEFLOGA = .FALSE.
CALL SCANVAT(1)
IF (FATAL) RETURN
GOTO 1
C
C PHYSICAL
C
700 CONTINUE
CALL SCANVAT(0)
IF (FATAL) RETURN
GOTO 1
C
C RANGE
C
600 CALL SCANRNG
IF (FATAL) RETURN
GOTO 1
C
C ENTRY
C
900 CONTINUE
CALL SCANMUS
IF (FATAL) RETURN
GOTO 1
C
C IO
C
1000 CONTINUE
IO = 0
IF (.NOT.SYMEQ('(')) THEN
LOOP = .FALSE.
GOTO 1002
ELSE
LOOP = .TRUE.
ENDIF
1001 CONTINUE
CALL SCANSYM
IF (FATAL) RETURN
IF (SYMEQ(')')) GOTO 1003
1002 CONTINUE
IF (UPSYMEQ('IN')) THEN
IO = IO.OR.1
ELSEIF (UPSYMEQ('OUT')) THEN
IO = IO.OR.2
ELSE
CALL EXPECT('IN ^O^R OUT','IO=')
RETURN
ENDIF
IF (LOOP) GOTO 1001
1003 CONTINUE
IF (IO.EQ.3.OR.IO.EQ.0) GOTO 1
CALL NEWVAT
IF (FATAL) RETURN
VAIO(NVAR) = IO
ATIO(NATR) = VAIO(NVAR)
GOTO 1
C
C HELP
C
1100 CONTINUE
IF (SYMTP.NE.'S') THEN
CALL EXPECT('^S^T^R^I^N^G','HELP')
RETURN
ENDIF
SAVV = NVAL + 1
SL = MIN(159,SL)
CALL COPYSYM
IF (FATAL) RETURN
VARH(NVAR) = SAVV
MSGL = MAX(MSGL,SL)
MSGX = MIN(39,80-MSGL)
GOTO 1
END
C-------------------------------------------------------------------
C* SCANVAT - SCAN VAR ATTRIBUTE
C
C ENTRY LOG=1 IF LOGICAL ATTRIBUTES, 0 IF PHYSICAL
C
SUBROUTINE SCANVAT(LOG)
*CALL COMFPAN
INTEGER LOG
CALL NEWVAT
IF (FATAL) RETURN
CALL SCANLPA(LOG)
END
C-------------------------------------------------------------------
C* SCANVIO - SCAN VAR IN OR OUT
C
C ENTRY IO = 1=IN ONLY, 2=OUT ONLY
C
SUBROUTINE SCANVIO(IO)
*CALL COMFPAN
INTEGER IO
CALL SCANSYM
IF (FATAL) RETURN
IF (UPSYMEQ('ONLY')) THEN
CALL SCANSYM
IF (FATAL) RETURN
ENDIF
END
C-------------------------------------------------------------------
C* SCANVKS - SCAN VAR KEYWORDS
C
C EXIT I=KEYWORD ORDINAL OR 0 IF NOT
C CURRENT SYM ADVANCED PAST KEYWORD= IF I.NE.0
C
SUBROUTINE SCANVKS(I)
*CALL COMFPAN
INTEGER I
I = 0
IF (.NOT.ZEQNEXT()) RETURN
IF (UPSYMEQ('NAME').OR.UPSYMEQ('N')) THEN
I = 1
ELSEIF (UPSYMEQ('TYPE').OR.UPSYMEQ('T')) THEN
I = 2
ELSEIF (UPSYMEQ('VALUE').OR.UPSYMEQ('V')) THEN
I = 3
ELSEIF (UPSYMEQ('FORMAT').OR.UPSYMEQ('F')) THEN
I = 4
ELSEIF (UPSYMEQ('MATCH').OR.UPSYMEQ('M')) THEN
I = 5
ELSEIF (UPSYMEQ('RANGE').OR.UPSYMEQ('R')) THEN
I = 6
ELSEIF (UPSYMEQ('PHYSICAL').OR.UPSYMEQ('P')) THEN
I = 7
ELSEIF (UPSYMEQ('LOGICAL').OR.UPSYMEQ('L')) THEN
I = 8
ELSEIF (UPSYMEQ('ENTRY').OR.UPSYMEQ('E')) THEN
I = 9
ELSEIF (UPSYMEQ('IO').OR.UPSYMEQ('I')) THEN
I = 10
ELSEIF (UPSYMEQ('HELP').OR.UPSYMEQ('H')) THEN
I = 11
ENDIF
IF (I.EQ.0) THEN
CALL ERROR('U^N^K^N^O^W^N ^K^E^Y^W^O^R^D')
RETURN
ELSE
CALL SKIPTWO
ENDIF
END
C-------------------------------------------------------------------
C SETATR - SET ATTRIBUTE
C
C ENTRY LP = 1=LOGICAL, 0=PHYSICAL
C I = 0,1,2,... PARALLEL USE IN CHEKATR
C
SUBROUTINE SETATR(LP,I)
*CALL COMFPAN
INTEGER LP, I
C PRINT 56, LP, I
56 FORMAT('SETATR, LP=',I1,' I=',I2)
ATRLP(NATR) = CHAR(LP + ICHAR('0'))
IF (I .EQ. 0) THEN
ATTP(NATR) = I
RETURN
ENDIF
GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17), I
RETURN
1 CONTINUE
2 CONTINUE
3 CONTINUE
4 CONTINUE
5 CONTINUE
ATTP(NATR) = I
RETURN
6 IF (LP.EQ.0) THEN
ATRBL(NATR) = '1'
ELSE
ATTP(NATR) = I
ENDIF
RETURN
7 IF (LP.EQ.0) THEN
ATRIV(NATR) = '1'
ELSE
ATTP(NATR) = I
ENDIF
RETURN
8 IF (LP.EQ.0) THEN
ATRUL(NATR) = '1'
ELSE
ATTP(NATR) = I
ENDIF
RETURN
9 IF (LP.EQ.0) THEN
ATRAI(NATR) = '1'
ELSE
ATTP(NATR) = I
ENDIF
RETURN
10 CONTINUE
11 CONTINUE
ATTP(NATR) = I
RETURN
12 CONTINUE
13 CONTINUE
14 CONTINUE
15 CONTINUE
16 CONTINUE
17 CONTINUE
RETURN
END
C-------------------------------------------------------------------
C* SETVARD - SET VARIABLE DEFAULT VALUE
C
SUBROUTINE SETVARD
*CALL COMFPAN
INTEGER SAVV
IF ((SYMTP.EQ.'S'.AND.VART(NVAR).EQ.VTC).OR.
A (SYMTP.EQ.'N'.AND.VART(NVAR).EQ.VTN).OR.
B (SYMTP.EQ.'R'.AND.VART(NVAR).EQ.VTR)) THEN
IF (SYMTP.EQ.'I') THEN
CALL EXPECT('^C^O^N^S^T^A^N^T','=')
RETURN
ENDIF
SAVV = NVAL + 1
CALL COPYSYM
IF (FATAL) RETURN
VARD(NVAR) = SAVV
ELSE
CALL ERROR('V^A^L^U^E ^T^Y^P^E ^M^I^S^M^A^T^C^H')
ENDIF
END
C-------------------------------------------------------------------
C* SETVARN - SET VAR NAME IN ARRAY
C
SUBROUTINE SETVARN
*CALL COMFPAN
CHARACTER*7 NAME
CHARACTER*40 ES
CALL NEWVAR
IF (FATAL) RETURN
NAME = STRGD(1:MIN(SL,7))
VARNM(NVAR) = NAME
I = 1
1 IF (VARNM(I).NE.NAME) THEN
I = I + 1
GOTO 1
ENDIF
IF (I.NE.NVAR) THEN
CALL ERROR('VAR ^D^E^C^L^A^R^E^D ^T^W^I^C^E')
NVAR = NVAR - 1
ENDIF
END
C-------------------------------------------------------------------
C* SKIPHED - SKIP TO HEAD
C
SUBROUTINE SKIPHED
*CALL COMFPAN
1 CONTINUE
CALL CHEKHED(I)
IF (I.NE.0) RETURN
CALL SCANSYM
GOTO 1
END
C-------------------------------------------------------------------
C* SKIPTWO - SKIP TWO SYMBOLS
C
SUBROUTINE SKIPTWO
*CALL COMFPAN
CALL SCANSYM
IF (FATAL) RETURN
CALL SCANSYM
END
C-------------------------------------------------------------------
C* SLEN - STRING LENGTH (INTEGER)
C
FUNCTION SLEN(S,L)
*CALL COMFPAN
INTEGER L
CHARACTER*(*) S
CHARACTER*1 C
I = 1
J = 0
1 CONTINUE
C = S(I:I)
IF (C.EQ.'@'.OR.C.EQ.'^') THEN
I = I + 1
ENDIF
J = J + 1
I = I + 1
IF (I.LE.L) GOTO 1
SLEN = J
END
C-------------------------------------------------------------------
C* SPP - SCAN PROGRAM PARAMETERS
C
SUBROUTINE SPP
*CALL COMFPAN
* GETPARM KEYWORD PARAMETER
CHARACTER*7 KEYWORD
* GETPARM RETURN VALUE
CHARACTER*7 VALUE
* FILE NAME OF PANEL
CHARACTER*7 PANEL
* LIST FILE NAME
CHARACTER*7 LIST
* CAPSULE SOURCE FILE NAME
CHARACTER*7 COMPASS
* NULL FILE FLAG
LOGICAL NULLFIL
DATA PANEL / 'PANEL' /
DATA LIST / 'OUTPUT' /
DATA COMPASS / 'COMPASS' /
DATA NULLFIL / .FALSE. /
* GET PARAMETERS FROM EXECUTION STATEMENT.
1 CALL GETPARM(KEYWORD,VALUE,I)
IF (I.EQ.-1) THEN
OPEN(1,ERR=10,FILE=PANEL,STATUS='OLD',RECL=266)
IF (.NOT.NULLFIL) THEN
OPEN(2,ERR=20,FILE=LIST,STATUS='UNKNOWN',RECL=266)
ELSE
OPEN(2,ERR=20,STATUS='SCRATCH',RECL=266)
ENDIF
OPEN(3,ERR=30,FILE=COMPASS,STATUS='UNKNOWN',RECL=80)
REWIND 1
PNAME = PANEL
REWIND 2
REWIND 3
RETURN
10 CALL QUITS('CAN''T OPEN FILE '//PANEL)
20 CALL QUITS('CAN''T OPEN FILE '//LIST)
30 CALL QUITS('CAN''T OPEN FILE '//COMPASS)
ENDIF
IF (KEYWORD.EQ.'I') THEN
IF (I.EQ.0) PANEL = VALUE
PNAME = PANEL
GOTO 1
ELSE IF (KEYWORD.EQ.'L') THEN
IF (I.EQ.0) THEN
IF (VALUE .EQ. '0') THEN
NULLFIL = .TRUE.
ELSE
LIST = VALUE
ENDIF
ENDIF
GOTO 1
ELSE IF (KEYWORD.EQ.'C') THEN
IF (I.EQ.0) COMPASS = VALUE
GOTO 1
ELSE
CALL QUITS('UNRECOGNIZED PARAMETER '//KEYWORD)
ENDIF
END
C-------------------------------------------------------------------
C* SYMEQ - SYMBOL EQUAL TO ARGUMENT
C
C ENTRY
C S = SINGLE DISPLAY CODE CHAR TO COMPARE TO SYMBOL
C
LOGICAL FUNCTION SYMEQ(S)
*CALL COMFPAN
CHARACTER*(1) S
SYMEQ = X612TA(ICHAR(S)).EQ.IMAG(SI,1).AND.SL.EQ.1
END
C-------------------------------------------------------------------
C* UPSYMEQ - .TRUE. IFF UPPER CASE OF CURRENT SYM .EQ. S
C
LOGICAL FUNCTION UPSYMEQ(S)
*CALL COMFPAN
CHARACTER*(*) S
J = 0
UPSYMEQ = .FALSE.
IF (SYMTP.EQ.'I'.AND.LEN(S).EQ.SL.AND.S.EQ.STRGD(1:SL))
A UPSYMEQ = .TRUE.
END
C-------------------------------------------------------------------
C* VFDN - VFD NUMBER
C
SUBROUTINE VFDN(S,N)
*CALL COMFPAN
CHARACTER*(*) S
INTEGER N
IF (N.LT.0) THEN
WRITE(3,200) S, -N
200 FORMAT(T10,'VFD',T16,A,'-',I4.4)
ELSE
WRITE(3,100) S, N
100 FORMAT(T10,'VFD',T16,A, I4.4)
ENDIF
END
C-------------------------------------------------------------------
C* VFDIF - VFD IF B TRUE
C
SUBROUTINE VFDIF(S1,B,S2)
*CALL COMFPAN
CHARACTER*(*) S1,S2
CHARACTER*40 S
IF (B.NE.0) THEN
S = S1//S2
CALL VFD(S)
ELSE
S = S1//'0'
CALL VFD(S)
ENDIF
END
C-------------------------------------------------------------------
C* VFD - VFD STRING
C
SUBROUTINE VFD(S)
*CALL COMFPAN
CHARACTER*(*) S
WRITE(3,100) S
100 FORMAT(T10,'VFD',T16,A)
END
C-------------------------------------------------------------------
C* VFDO - VFD OCTAL WORD
C
SUBROUTINE VFDO(S,W)
*CALL COMFPAN
CHARACTER*(*) S
INTEGER W
WRITE(3,100) S, W
100 FORMAT(T10,'VFD',T16,A,O20,'B')
END
C-------------------------------------------------------------------
C* VFDO2 - VFD INTEGER AS OCTAL 2
C
SUBROUTINE VFDO2(S,I)
*CALL COMFPAN
CHARACTER*(*) S
INTEGER I
WRITE(3,100) S, I
100 FORMAT(T10,'VFD',T16,A,O2)
END
C-------------------------------------------------------------------
C* VFDB - VFD LOGICAL (1 0R 0)
C
SUBROUTINE VFDB(B)
*CALL COMFPAN
INTEGER B
IF (B.NE.0) THEN
CALL VFD('1/1')
ELSE
CALL VFD('1/0')
ENDIF
END
C* XLINE - XLATE LINE FROM 6/12 TO ASCII
C
SUBROUTINE XLINE(LNO)
*CALL COMFPAN
INTEGER LNO
N = 0
DO 200 I = 1,MCOL
N = N + 1
J = 0
IF (LINE(N:N).EQ.'^') THEN
J = Z"40"
N = N + 1
ELSEIF (LINE(N:N).EQ.'@') THEN
J = Z"80"
N = N + 1
ENDIF
IMAG(I,LNO) = X612TA(J + ICHAR(LINE(N:N)))
200 CONTINUE
IMAG(MCOL+1,LNO) = 0
END
C-------------------------------------------------------------------
C* ZEQNEXT - TRUE IF = NEXT CHARACTER ON SAME LINE
C
LOGICAL FUNCTION ZEQNEXT()
*CALL COMFPAN
J = SJ
1 IF (IMAG(J,1).EQ.ZSP) THEN
IF (J.LE.MCOL) THEN
J = J + 1
GOTO 1
ENDIF
ENDIF
ZEQNEXT = IMAG(J,1).EQ.ZEQ
END