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